{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TemplateHaskellQuotes #-}

{-|
Module:      Data.Aeson.TH
Copyright:   (c) 2011-2016 Bryan O'Sullivan
             (c) 2011 MailRank, Inc.
License:     BSD3
Stability:   experimental
Portability: portable

Functions to mechanically derive 'ToJSON' and 'FromJSON' instances. Note that
you need to enable the @TemplateHaskell@ language extension in order to use this
module.

An example shows how instances are generated for arbitrary data types. First we
define a data type:

@
data D a = Nullary
         | Unary Int
         | Product String Char a
         | Record { testOne   :: Double
                  , testTwo   :: Bool
                  , testThree :: D a
                  } deriving Eq
@

Next we derive the necessary instances. Note that we make use of the
feature to change record field names. In this case we drop the first 4
characters of every field name. We also modify constructor names by
lower-casing them:

@
$('deriveJSON' 'defaultOptions'{'fieldLabelModifier' = 'drop' 4, 'constructorTagModifier' = map toLower} ''D)
@

Now we can use the newly created instances.

@
d :: D 'Int'
d = Record { testOne = 3.14159
           , testTwo = 'True'
           , testThree = Product \"test\" \'A\' 123
           }
@

@
fromJSON (toJSON d) == Success d
@

This also works for data family instances, but instead of passing in the data
family name (with double quotes), we pass in a data family instance
constructor (with a single quote):

@
data family DF a
data instance DF Int = DF1 Int
                     | DF2 Int Int
                     deriving Eq

$('deriveJSON' 'defaultOptions' 'DF1)
-- Alternatively, one could pass 'DF2 instead
@

Please note that you can derive instances for tuples using the following syntax:

@
-- FromJSON and ToJSON instances for 4-tuples.
$('deriveJSON' 'defaultOptions' ''(,,,))
@

If you derive `ToJSON` for a type that has no constructors, the splice will
require enabling @EmptyCase@ to compile.

-}
module Data.Aeson.TH
    (
      -- * Encoding configuration
      Options(..)
    , SumEncoding(..)
    , defaultOptions
    , defaultTaggedObject

     -- * FromJSON and ToJSON derivation
    , deriveJSON
    , deriveJSON1
    , deriveJSON2

    , deriveToJSON
    , deriveToJSON1
    , deriveToJSON2
    , deriveFromJSON
    , deriveFromJSON1
    , deriveFromJSON2

    , mkToJSON
    , mkLiftToJSON
    , mkLiftToJSON2
    , mkToEncoding
    , mkLiftToEncoding
    , mkLiftToEncoding2
    , mkParseJSON
    , mkLiftParseJSON
    , mkLiftParseJSON2
    ) where

import Prelude.Compat hiding (fail)

-- We don't have MonadFail Q, so we should use `fail` from real `Prelude`
import Prelude (fail)

import Control.Applicative ((<|>))
import Data.Char (ord)
import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))
import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject)
import Data.Aeson.Types.Internal ((<?>), JSONPathElement(Key))
import Data.Aeson.Types.FromJSON (parseOptionalFieldWith)
import Data.Aeson.Types.ToJSON (fromPairs, pair)
import Data.Aeson.Key (Key)
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KM
import Control.Monad (liftM2, unless, when)
import Data.Foldable (foldr')
#if MIN_VERSION_template_haskell(2,8,0) && !MIN_VERSION_template_haskell(2,10,0)
import Data.List (nub)
#endif
import Data.List (foldl', genericLength, intercalate, partition, union)
import Data.List.NonEmpty ((<|), NonEmpty((:|)))
import Data.Map (Map)
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import qualified Data.Monoid as Monoid
import Data.Set (Set)
import Language.Haskell.TH hiding (Arity)
import Language.Haskell.TH.Datatype
#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0))
import Language.Haskell.TH.Syntax (mkNameG_tc)
#endif
import Text.Printf (printf)
import qualified Data.Aeson.Encoding.Internal as E
import qualified Data.Foldable as F (all)
import qualified Data.List.NonEmpty as NE (length, reverse)
import qualified Data.Map as M (fromList, keys, lookup , singleton, size)
#if !MIN_VERSION_base(4,16,0)
import qualified Data.Semigroup as Semigroup (Option(..))
#endif
import qualified Data.Set as Set (empty, insert, member)
import qualified Data.Text as T (pack, unpack)
import qualified Data.Vector as V (unsafeIndex, null, length, create, empty)
import qualified Data.Vector.Mutable as VM (unsafeNew, unsafeWrite)
import qualified Data.Text.Short as ST
import Data.ByteString.Short (ShortByteString)
import Data.Aeson.Internal.ByteString
import Data.Aeson.Internal.TH

--------------------------------------------------------------------------------
-- Convenience
--------------------------------------------------------------------------------

-- | Generates both 'ToJSON' and 'FromJSON' instance declarations for the given
-- data type or data family instance constructor.
--
-- This is a convenience function which is equivalent to calling both
-- 'deriveToJSON' and 'deriveFromJSON'.
deriveJSON :: Options
           -- ^ Encoding options.
           -> Name
           -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON'
           -- instances.
           -> Q [Dec]
deriveJSON :: Options -> Name -> Q [Dec]
deriveJSON = (Options -> Name -> Q [Dec])
-> (Options -> Name -> Q [Dec]) -> Options -> Name -> Q [Dec]
deriveJSONBoth Options -> Name -> Q [Dec]
deriveToJSON Options -> Name -> Q [Dec]
deriveFromJSON

-- | Generates both 'ToJSON1' and 'FromJSON1' instance declarations for the given
-- data type or data family instance constructor.
--
-- This is a convenience function which is equivalent to calling both
-- 'deriveToJSON1' and 'deriveFromJSON1'.
deriveJSON1 :: Options
            -- ^ Encoding options.
            -> Name
            -- ^ Name of the type for which to generate 'ToJSON1' and 'FromJSON1'
            -- instances.
            -> Q [Dec]
deriveJSON1 :: Options -> Name -> Q [Dec]
deriveJSON1 = (Options -> Name -> Q [Dec])
-> (Options -> Name -> Q [Dec]) -> Options -> Name -> Q [Dec]
deriveJSONBoth Options -> Name -> Q [Dec]
deriveToJSON1 Options -> Name -> Q [Dec]
deriveFromJSON1

-- | Generates both 'ToJSON2' and 'FromJSON2' instance declarations for the given
-- data type or data family instance constructor.
--
-- This is a convenience function which is equivalent to calling both
-- 'deriveToJSON2' and 'deriveFromJSON2'.
deriveJSON2 :: Options
            -- ^ Encoding options.
            -> Name
            -- ^ Name of the type for which to generate 'ToJSON2' and 'FromJSON2'
            -- instances.
            -> Q [Dec]
deriveJSON2 :: Options -> Name -> Q [Dec]
deriveJSON2 = (Options -> Name -> Q [Dec])
-> (Options -> Name -> Q [Dec]) -> Options -> Name -> Q [Dec]
deriveJSONBoth Options -> Name -> Q [Dec]
deriveToJSON2 Options -> Name -> Q [Dec]
deriveFromJSON2

--------------------------------------------------------------------------------
-- ToJSON
--------------------------------------------------------------------------------

{-
TODO: Don't constrain phantom type variables.

data Foo a = Foo Int
instance (ToJSON a) ⇒ ToJSON Foo where ...

The above (ToJSON a) constraint is not necessary and perhaps undesirable.
-}

-- | Generates a 'ToJSON' instance declaration for the given data type or
-- data family instance constructor.
deriveToJSON :: Options
             -- ^ Encoding options.
             -> Name
             -- ^ Name of the type for which to generate a 'ToJSON' instance
             -- declaration.
             -> Q [Dec]
deriveToJSON :: Options -> Name -> Q [Dec]
deriveToJSON = JSONClass -> Options -> Name -> Q [Dec]
deriveToJSONCommon JSONClass
toJSONClass

-- | Generates a 'ToJSON1' instance declaration for the given data type or
-- data family instance constructor.
deriveToJSON1 :: Options
              -- ^ Encoding options.
              -> Name
              -- ^ Name of the type for which to generate a 'ToJSON1' instance
              -- declaration.
              -> Q [Dec]
deriveToJSON1 :: Options -> Name -> Q [Dec]
deriveToJSON1 = JSONClass -> Options -> Name -> Q [Dec]
deriveToJSONCommon JSONClass
toJSON1Class

-- | Generates a 'ToJSON2' instance declaration for the given data type or
-- data family instance constructor.
deriveToJSON2 :: Options
              -- ^ Encoding options.
              -> Name
              -- ^ Name of the type for which to generate a 'ToJSON2' instance
              -- declaration.
              -> Q [Dec]
deriveToJSON2 :: Options -> Name -> Q [Dec]
deriveToJSON2 = JSONClass -> Options -> Name -> Q [Dec]
deriveToJSONCommon JSONClass
toJSON2Class

deriveToJSONCommon :: JSONClass
                   -- ^ The ToJSON variant being derived.
                   -> Options
                   -- ^ Encoding options.
                   -> Name
                   -- ^ Name of the type for which to generate an instance.
                   -> Q [Dec]
deriveToJSONCommon :: JSONClass -> Options -> Name -> Q [Dec]
deriveToJSONCommon = [(JSONFun,
  JSONClass
  -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)]
-> JSONClass -> Options -> Name -> Q [Dec]
deriveJSONClass [ (JSONFun
ToJSON,     \JSONClass
jc Name
_ -> ToJSONFun
-> JSONClass -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
consToValue ToJSONFun
Value JSONClass
jc)
                                     , (JSONFun
ToEncoding, \JSONClass
jc Name
_ -> ToJSONFun
-> JSONClass -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
consToValue ToJSONFun
Encoding JSONClass
jc)
                                     ]

-- | Generates a lambda expression which encodes the given data type or
-- data family instance constructor as a 'Value'.
mkToJSON :: Options -- ^ Encoding options.
         -> Name -- ^ Name of the type to encode.
         -> Q Exp
mkToJSON :: Options -> Name -> Q Exp
mkToJSON = JSONClass -> Options -> Name -> Q Exp
mkToJSONCommon JSONClass
toJSONClass

-- | Generates a lambda expression which encodes the given data type or
-- data family instance constructor as a 'Value' by using the given encoding
-- function on occurrences of the last type parameter.
mkLiftToJSON :: Options -- ^ Encoding options.
             -> Name -- ^ Name of the type to encode.
             -> Q Exp
mkLiftToJSON :: Options -> Name -> Q Exp
mkLiftToJSON = JSONClass -> Options -> Name -> Q Exp
mkToJSONCommon JSONClass
toJSON1Class

-- | Generates a lambda expression which encodes the given data type or
-- data family instance constructor as a 'Value' by using the given encoding
-- functions on occurrences of the last two type parameters.
mkLiftToJSON2 :: Options -- ^ Encoding options.
              -> Name -- ^ Name of the type to encode.
              -> Q Exp
mkLiftToJSON2 :: Options -> Name -> Q Exp
mkLiftToJSON2 = JSONClass -> Options -> Name -> Q Exp
mkToJSONCommon JSONClass
toJSON2Class

mkToJSONCommon :: JSONClass -- ^ Which class's method is being derived.
               -> Options -- ^ Encoding options.
               -> Name -- ^ Name of the encoded type.
               -> Q Exp
mkToJSONCommon :: JSONClass -> Options -> Name -> Q Exp
mkToJSONCommon = (JSONClass
 -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
-> JSONClass -> Options -> Name -> Q Exp
mkFunCommon (\JSONClass
jc Name
_ -> ToJSONFun
-> JSONClass -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
consToValue ToJSONFun
Value JSONClass
jc)

-- | Generates a lambda expression which encodes the given data type or
-- data family instance constructor as a JSON string.
mkToEncoding :: Options -- ^ Encoding options.
             -> Name -- ^ Name of the type to encode.
             -> Q Exp
mkToEncoding :: Options -> Name -> Q Exp
mkToEncoding = JSONClass -> Options -> Name -> Q Exp
mkToEncodingCommon JSONClass
toJSONClass

-- | Generates a lambda expression which encodes the given data type or
-- data family instance constructor as a JSON string by using the given encoding
-- function on occurrences of the last type parameter.
mkLiftToEncoding :: Options -- ^ Encoding options.
                 -> Name -- ^ Name of the type to encode.
                 -> Q Exp
mkLiftToEncoding :: Options -> Name -> Q Exp
mkLiftToEncoding = JSONClass -> Options -> Name -> Q Exp
mkToEncodingCommon JSONClass
toJSON1Class

-- | Generates a lambda expression which encodes the given data type or
-- data family instance constructor as a JSON string by using the given encoding
-- functions on occurrences of the last two type parameters.
mkLiftToEncoding2 :: Options -- ^ Encoding options.
                  -> Name -- ^ Name of the type to encode.
                  -> Q Exp
mkLiftToEncoding2 :: Options -> Name -> Q Exp
mkLiftToEncoding2 = JSONClass -> Options -> Name -> Q Exp
mkToEncodingCommon JSONClass
toJSON2Class

mkToEncodingCommon :: JSONClass -- ^ Which class's method is being derived.
                   -> Options -- ^ Encoding options.
                   -> Name -- ^ Name of the encoded type.
                   -> Q Exp
mkToEncodingCommon :: JSONClass -> Options -> Name -> Q Exp
mkToEncodingCommon = (JSONClass
 -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
-> JSONClass -> Options -> Name -> Q Exp
mkFunCommon (\JSONClass
jc Name
_ -> ToJSONFun
-> JSONClass -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
consToValue ToJSONFun
Encoding JSONClass
jc)

type LetInsert = ShortByteString -> ExpQ

-- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates
-- code to generate a 'Value' or 'Encoding' of a number of constructors. All
-- constructors must be from the same type.
consToValue :: ToJSONFun
            -- ^ The method ('toJSON' or 'toEncoding') being derived.
            -> JSONClass
            -- ^ The ToJSON variant being derived.
            -> Options
            -- ^ Encoding options.
            -> [Type]
            -- ^ The types from the data type/data family instance declaration
            -> [ConstructorInfo]
            -- ^ Constructors for which to generate JSON generating code.
            -> Q Exp

consToValue :: ToJSONFun
-> JSONClass -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
consToValue ToJSONFun
_ JSONClass
_ Options
_ [Type]
_ [] =
    [| \x -> case x of {} |]

consToValue ToJSONFun
target JSONClass
jc Options
opts [Type]
instTys [ConstructorInfo]
cons = forall a. Ord a => (a -> Q Exp) -> ((a -> Q Exp) -> Q Exp) -> Q Exp
autoletE ShortByteString -> Q Exp
liftSBS forall a b. (a -> b) -> a -> b
$ \ShortByteString -> Q Exp
letInsert -> do
    Name
value <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"value"
    [Name]
tjs   <- String -> Int -> Q [Name]
newNameList String
"_tj"  forall a b. (a -> b) -> a -> b
$ JSONClass -> Int
arityInt JSONClass
jc
    [Name]
tjls  <- String -> Int -> Q [Name]
newNameList String
"_tjl" forall a b. (a -> b) -> a -> b
$ JSONClass -> Int
arityInt JSONClass
jc
    let zippedTJs :: [(Name, Name)]
zippedTJs      = forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
tjs [Name]
tjls
        interleavedTJs :: [Name]
interleavedTJs = forall a. [a] -> [a] -> [a]
interleave [Name]
tjs [Name]
tjls
        lastTyVars :: [Name]
lastTyVars     = forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
instTys forall a. Num a => a -> a -> a
- JSONClass -> Int
arityInt JSONClass
jc) [Type]
instTys
        tvMap :: Map Name (Name, Name)
tvMap          = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
lastTyVars [(Name, Name)]
zippedTJs
    forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP forall a b. (a -> b) -> a -> b
$ [Name]
interleavedTJs forall a. [a] -> [a] -> [a]
++ [Name
value]) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value) ((ShortByteString -> Q Exp) -> Map Name (Name, Name) -> [Q Match]
matches ShortByteString -> Q Exp
letInsert Map Name (Name, Name)
tvMap)
  where
    matches :: (ShortByteString -> Q Exp) -> Map Name (Name, Name) -> [Q Match]
matches ShortByteString -> Q Exp
letInsert Map Name (Name, Name)
tvMap = case [ConstructorInfo]
cons of
      -- A single constructor is directly encoded. The constructor itself may be
      -- forgotten.
      [ConstructorInfo
con] | Bool -> Bool
not (Options -> Bool
tagSingleConstructors Options
opts) -> [(ShortByteString -> Q Exp)
-> ToJSONFun
-> JSONClass
-> Map Name (Name, Name)
-> Options
-> Bool
-> ConstructorInfo
-> Q Match
argsToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target JSONClass
jc Map Name (Name, Name)
tvMap Options
opts Bool
False ConstructorInfo
con]
      [ConstructorInfo]
_ | Options -> Bool
allNullaryToStringTag Options
opts Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ConstructorInfo -> Bool
isNullary [ConstructorInfo]
cons ->
              [ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName []) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ ToJSONFun -> Options -> Name -> Q Exp
conStr ToJSONFun
target Options
opts Name
conName) []
              | ConstructorInfo
con <- [ConstructorInfo]
cons
              , let conName :: Name
conName = ConstructorInfo -> Name
constructorName ConstructorInfo
con
              ]
        | Bool
otherwise -> [(ShortByteString -> Q Exp)
-> ToJSONFun
-> JSONClass
-> Map Name (Name, Name)
-> Options
-> Bool
-> ConstructorInfo
-> Q Match
argsToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target JSONClass
jc Map Name (Name, Name)
tvMap Options
opts Bool
True ConstructorInfo
con | ConstructorInfo
con <- [ConstructorInfo]
cons]

-- | Name of the constructor as a quoted 'Value' or 'Encoding'.
conStr :: ToJSONFun -> Options -> Name -> Q Exp
conStr :: ToJSONFun -> Options -> Name -> Q Exp
conStr ToJSONFun
Value Options
opts = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|String|] forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> Name -> Q Exp
conTxt Options
opts
conStr ToJSONFun
Encoding Options
opts = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|E.text|] forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> Name -> Q Exp
conTxt Options
opts

-- | Name of the constructor as a quoted 'Text'.
conTxt :: Options -> Name -> Q Exp
conTxt :: Options -> Name -> Q Exp
conTxt Options
opts = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|T.pack|] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => String -> m Exp
stringE forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> Name -> String
conString Options
opts

-- | Name of the constructor.
conString :: Options -> Name -> String
conString :: Options -> Name -> String
conString Options
opts = Options -> String -> String
constructorTagModifier Options
opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase

-- | If constructor is nullary.
isNullary :: ConstructorInfo -> Bool
isNullary :: ConstructorInfo -> Bool
isNullary ConstructorInfo { constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
NormalConstructor
                          , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
tys } = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
tys
isNullary ConstructorInfo
_ = Bool
False

-- | Wrap fields of a non-record constructor. See 'sumToValue'.
opaqueSumToValue :: LetInsert -> ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ
opaqueSumToValue :: (ShortByteString -> Q Exp)
-> ToJSONFun -> Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp
opaqueSumToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target Options
opts Bool
multiCons Bool
nullary Name
conName Q Exp
value =
  (ShortByteString -> Q Exp)
-> ToJSONFun
-> Options
-> Bool
-> Bool
-> Name
-> Q Exp
-> (String -> Q Exp)
-> Q Exp
sumToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target Options
opts Bool
multiCons Bool
nullary Name
conName
    Q Exp
value
    String -> Q Exp
pairs
  where
    pairs :: String -> Q Exp
pairs String
contentsFieldName = (ShortByteString -> Q Exp) -> ToJSONFun -> String -> Q Exp -> Q Exp
pairE ShortByteString -> Q Exp
letInsert ToJSONFun
target String
contentsFieldName Q Exp
value

-- | Wrap fields of a record constructor. See 'sumToValue'.
recordSumToValue :: LetInsert -> ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ
recordSumToValue :: (ShortByteString -> Q Exp)
-> ToJSONFun -> Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp
recordSumToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target Options
opts Bool
multiCons Bool
nullary Name
conName Q Exp
pairs =
  (ShortByteString -> Q Exp)
-> ToJSONFun
-> Options
-> Bool
-> Bool
-> Name
-> Q Exp
-> (String -> Q Exp)
-> Q Exp
sumToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target Options
opts Bool
multiCons Bool
nullary Name
conName
    (ToJSONFun -> Q Exp -> Q Exp
fromPairsE ToJSONFun
target Q Exp
pairs)
    (forall a b. a -> b -> a
const Q Exp
pairs)

-- | Wrap fields of a constructor.
sumToValue
  :: LetInsert
  -- ^ Let insertion
  -> ToJSONFun
  -- ^ The method being derived.
  -> Options
  -- ^ Deriving options.
  -> Bool
  -- ^ Does this type have multiple constructors.
  -> Bool
  -- ^ Is this constructor nullary.
  -> Name
  -- ^ Constructor name.
  -> ExpQ
  -- ^ Fields of the constructor as a 'Value' or 'Encoding'.
  -> (String -> ExpQ)
  -- ^ Representation of an 'Object' fragment used for the 'TaggedObject'
  -- variant; of type @[(Text,Value)]@ or @[Encoding]@, depending on the method
  -- being derived.
  --
  -- - For non-records, produces a pair @"contentsFieldName":value@,
  --   given a @contentsFieldName@ as an argument. See 'opaqueSumToValue'.
  -- - For records, produces the list of pairs corresponding to fields of the
  --   encoded value (ignores the argument). See 'recordSumToValue'.
  -> ExpQ
sumToValue :: (ShortByteString -> Q Exp)
-> ToJSONFun
-> Options
-> Bool
-> Bool
-> Name
-> Q Exp
-> (String -> Q Exp)
-> Q Exp
sumToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target Options
opts Bool
multiCons Bool
nullary Name
conName Q Exp
value String -> Q Exp
pairs
    | Bool
multiCons =
        case Options -> SumEncoding
sumEncoding Options
opts of
          SumEncoding
TwoElemArray ->
            ToJSONFun -> [Q Exp] -> Q Exp
array ToJSONFun
target [ToJSONFun -> Options -> Name -> Q Exp
conStr ToJSONFun
target Options
opts Name
conName, Q Exp
value]
          TaggedObject{String
tagFieldName :: SumEncoding -> String
tagFieldName :: String
tagFieldName, String
contentsFieldName :: SumEncoding -> String
contentsFieldName :: String
contentsFieldName} ->
            -- TODO: Maybe throw an error in case
            -- tagFieldName overwrites a field in pairs.
            let tag :: Q Exp
tag = (ShortByteString -> Q Exp) -> ToJSONFun -> String -> Q Exp -> Q Exp
pairE ShortByteString -> Q Exp
letInsert ToJSONFun
target String
tagFieldName (ToJSONFun -> Options -> Name -> Q Exp
conStr ToJSONFun
target Options
opts Name
conName)
                content :: Q Exp
content = String -> Q Exp
pairs String
contentsFieldName
            in ToJSONFun -> Q Exp -> Q Exp
fromPairsE ToJSONFun
target forall a b. (a -> b) -> a -> b
$
              if Bool
nullary then Q Exp
tag else forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
tag [|(Monoid.<>)|] Q Exp
content
          SumEncoding
ObjectWithSingleField ->
            (ShortByteString -> Q Exp)
-> ToJSONFun -> [(String, Q Exp)] -> Q Exp
objectE ShortByteString -> Q Exp
letInsert ToJSONFun
target [(Options -> Name -> String
conString Options
opts Name
conName, Q Exp
value)]
          SumEncoding
UntaggedValue | Bool
nullary -> ToJSONFun -> Options -> Name -> Q Exp
conStr ToJSONFun
target Options
opts Name
conName
          SumEncoding
UntaggedValue -> Q Exp
value
    | Bool
otherwise = Q Exp
value

-- | Generates code to generate the JSON encoding of a single constructor.
argsToValue :: LetInsert -> ToJSONFun -> JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match

-- Polyadic constructors with special case for unary constructors.
argsToValue :: (ShortByteString -> Q Exp)
-> ToJSONFun
-> JSONClass
-> Map Name (Name, Name)
-> Options
-> Bool
-> ConstructorInfo
-> Q Match
argsToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target JSONClass
jc Map Name (Name, Name)
tvMap Options
opts Bool
multiCons
  ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                  , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
NormalConstructor
                  , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
argTys } = do
    [Type]
argTys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms [Type]
argTys
    let len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
argTys'
    [Name]
args <- String -> Int -> Q [Name]
newNameList String
"arg" Int
len
    let js :: Q Exp
js = case [ ToJSONFun
-> JSONClass -> Name -> Map Name (Name, Name) -> Type -> Q Exp
dispatchToJSON ToJSONFun
target JSONClass
jc Name
conName Map Name (Name, Name)
tvMap Type
argTy
                      forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
arg
                  | (Name
arg, Type
argTy) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
args [Type]
argTys'
                  ] of
               -- Single argument is directly converted.
               [Q Exp
e] -> Q Exp
e
               -- Zero and multiple arguments are converted to a JSON array.
               [Q Exp]
es -> ToJSONFun -> [Q Exp] -> Q Exp
array ToJSONFun
target [Q Exp]
es

    forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
args)
          (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ (ShortByteString -> Q Exp)
-> ToJSONFun -> Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp
opaqueSumToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target Options
opts Bool
multiCons (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
argTys') Name
conName Q Exp
js)
          []

-- Records.
argsToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target JSONClass
jc Map Name (Name, Name)
tvMap Options
opts Bool
multiCons
  info :: ConstructorInfo
info@ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                       , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = RecordConstructor [Name]
fields
                       , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
argTys } =
    case (Options -> Bool
unwrapUnaryRecords Options
opts, Bool -> Bool
not Bool
multiCons, [Type]
argTys) of
      (Bool
True,Bool
True,[Type
_]) -> (ShortByteString -> Q Exp)
-> ToJSONFun
-> JSONClass
-> Map Name (Name, Name)
-> Options
-> Bool
-> ConstructorInfo
-> Q Match
argsToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target JSONClass
jc Map Name (Name, Name)
tvMap Options
opts Bool
multiCons
                                     (ConstructorInfo
info{constructorVariant :: ConstructorVariant
constructorVariant = ConstructorVariant
NormalConstructor})
      (Bool, Bool, [Type])
_ -> do
        [Type]
argTys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms [Type]
argTys
        [Name]
args <- String -> Int -> Q [Name]
newNameList String
"arg" forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
argTys'
        let pairs :: Q Exp
pairs | Options -> Bool
omitNothingFields Options
opts = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
maybeFields
                                                      [|(Monoid.<>)|]
                                                      Q Exp
restFields
                  | Bool
otherwise = [Q Exp] -> Q Exp
mconcatE (forall a b. (a -> b) -> [a] -> [b]
map (Q Exp, Type, Name) -> Q Exp
pureToPair [(Q Exp, Type, Name)]
argCons)

            argCons :: [(Q Exp, Type, Name)]
argCons = forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
args) [Type]
argTys' [Name]
fields

            maybeFields :: Q Exp
maybeFields = [Q Exp] -> Q Exp
mconcatE (forall a b. (a -> b) -> [a] -> [b]
map (Q Exp, Type, Name) -> Q Exp
maybeToPair [(Q Exp, Type, Name)]
maybes)

            restFields :: Q Exp
restFields = [Q Exp] -> Q Exp
mconcatE (forall a b. (a -> b) -> [a] -> [b]
map (Q Exp, Type, Name) -> Q Exp
pureToPair [(Q Exp, Type, Name)]
rest)

            ([(Q Exp, Type, Name)]
maybes0, [(Q Exp, Type, Name)]
rest0) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition forall a b. (a, Type, b) -> Bool
isMaybe [(Q Exp, Type, Name)]
argCons
#if MIN_VERSION_base(4,16,0)
            maybes :: [(Q Exp, Type, Name)]
maybes = [(Q Exp, Type, Name)]
maybes0
            rest :: [(Q Exp, Type, Name)]
rest   = [(Q Exp, Type, Name)]
rest0
#else
            (options, rest) = partition isOption rest0
            maybes = maybes0 ++ map optionToMaybe options
#endif

            maybeToPair :: (Q Exp, Type, Name) -> Q Exp
maybeToPair = Bool -> (Q Exp, Type, Name) -> Q Exp
toPairLifted Bool
True
            pureToPair :: (Q Exp, Type, Name) -> Q Exp
pureToPair = Bool -> (Q Exp, Type, Name) -> Q Exp
toPairLifted Bool
False

            toPairLifted :: Bool -> (Q Exp, Type, Name) -> Q Exp
toPairLifted Bool
lifted (Q Exp
arg, Type
argTy, Name
field) =
              let toValue :: Q Exp
toValue = ToJSONFun
-> JSONClass -> Name -> Map Name (Name, Name) -> Type -> Q Exp
dispatchToJSON ToJSONFun
target JSONClass
jc Name
conName Map Name (Name, Name)
tvMap Type
argTy
                  fieldName :: String
fieldName = Options -> Name -> String
fieldLabel Options
opts Name
field
                  e :: Q Exp -> Q Exp
e Q Exp
arg' = (ShortByteString -> Q Exp) -> ToJSONFun -> String -> Q Exp -> Q Exp
pairE ShortByteString -> Q Exp
letInsert ToJSONFun
target String
fieldName (Q Exp
toValue forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
arg')
              in if Bool
lifted
                then do
                  Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
                  [|maybe mempty|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x) (Q Exp -> Q Exp
e (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x)) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
arg
                else Q Exp -> Q Exp
e Q Exp
arg

        forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
args)
              (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ (ShortByteString -> Q Exp)
-> ToJSONFun -> Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp
recordSumToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target Options
opts Bool
multiCons (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
argTys) Name
conName Q Exp
pairs)
              []

-- Infix constructors.
argsToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target JSONClass
jc Map Name (Name, Name)
tvMap Options
opts Bool
multiCons
  ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                  , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
InfixConstructor
                  , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
argTys } = do
    [Type
alTy, Type
arTy] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms [Type]
argTys
    Name
al <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"argL"
    Name
ar <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"argR"
    forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => m Pat -> Name -> m Pat -> m Pat
infixP (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
al) Name
conName (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
ar))
          ( forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
          forall a b. (a -> b) -> a -> b
$ (ShortByteString -> Q Exp)
-> ToJSONFun -> Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp
opaqueSumToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target Options
opts Bool
multiCons Bool
False Name
conName
          forall a b. (a -> b) -> a -> b
$ ToJSONFun -> [Q Exp] -> Q Exp
array ToJSONFun
target
              [ ToJSONFun
-> JSONClass -> Name -> Map Name (Name, Name) -> Type -> Q Exp
dispatchToJSON ToJSONFun
target JSONClass
jc Name
conName Map Name (Name, Name)
tvMap Type
aTy
                  forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
a
              | (Name
a, Type
aTy) <- [(Name
al,Type
alTy), (Name
ar,Type
arTy)]
              ]
          )
          []

isMaybe :: (a, Type, b) -> Bool
isMaybe :: forall a b. (a, Type, b) -> Bool
isMaybe (a
_, AppT (ConT Name
t) Type
_, b
_) = Name
t forall a. Eq a => a -> a -> Bool
== ''Maybe
isMaybe (a, Type, b)
_                       = Bool
False

#if !MIN_VERSION_base(4,16,0)
isOption :: (a, Type, b) -> Bool
isOption (_, AppT (ConT t) _, _) = t == ''Semigroup.Option
isOption _                       = False

optionToMaybe :: (ExpQ, b, c) -> (ExpQ, b, c)
optionToMaybe (a, b, c) = ([|Semigroup.getOption|] `appE` a, b, c)
#endif

(<^>) :: ExpQ -> ExpQ -> ExpQ
<^> :: Q Exp -> Q Exp -> Q Exp
(<^>) Q Exp
a Q Exp
b = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
a [|(E.><)|] Q Exp
b
infixr 6 <^>

(<%>) :: ExpQ -> ExpQ -> ExpQ
<%> :: Q Exp -> Q Exp -> Q Exp
(<%>) Q Exp
a Q Exp
b = Q Exp
a Q Exp -> Q Exp -> Q Exp
<^> [|E.comma|] Q Exp -> Q Exp -> Q Exp
<^> Q Exp
b
infixr 4 <%>

-- | Wrap a list of quoted 'Value's in a quoted 'Array' (of type 'Value').
array :: ToJSONFun -> [ExpQ] -> ExpQ
array :: ToJSONFun -> [Q Exp] -> Q Exp
array ToJSONFun
Encoding [] = [|E.emptyArray_|]
array ToJSONFun
Value [] = [|Array V.empty|]
array ToJSONFun
Encoding [Q Exp]
es = [|E.wrapArray|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Q Exp -> Q Exp -> Q Exp
(<%>) [Q Exp]
es
array ToJSONFun
Value [Q Exp]
es = do
  Name
mv <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"mv"
  let newMV :: Q Stmt
newMV = forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
bindS (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
mv)
                    ([|VM.unsafeNew|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
                      forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Integer -> Lit
integerL forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q Exp]
es)))
      stmts :: [Q Stmt]
stmts = [ forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS forall a b. (a -> b) -> a -> b
$
                  [|VM.unsafeWrite|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
                    forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
mv forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
                      forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Integer -> Lit
integerL Integer
ix) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
                        Q Exp
e
              | (Integer
ix, Q Exp
e) <- forall a b. [a] -> [b] -> [(a, b)]
zip [(Integer
0::Integer)..] [Q Exp]
es
              ]
      ret :: Q Stmt
ret = forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS forall a b. (a -> b) -> a -> b
$ [|return|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
mv
  [|Array|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
             (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'V.create forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
               forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
doE (Q Stmt
newMVforall a. a -> [a] -> [a]
:[Q Stmt]
stmtsforall a. [a] -> [a] -> [a]
++[Q Stmt
ret]))

-- | Wrap an associative list of keys and quoted values in a quoted 'Object'.
objectE :: LetInsert -> ToJSONFun -> [(String, ExpQ)] -> ExpQ
objectE :: (ShortByteString -> Q Exp)
-> ToJSONFun -> [(String, Q Exp)] -> Q Exp
objectE ShortByteString -> Q Exp
letInsert ToJSONFun
target = ToJSONFun -> Q Exp -> Q Exp
fromPairsE ToJSONFun
target forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Exp] -> Q Exp
mconcatE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((ShortByteString -> Q Exp) -> ToJSONFun -> String -> Q Exp -> Q Exp
pairE ShortByteString -> Q Exp
letInsert ToJSONFun
target))

-- | 'mconcat' a list of fixed length.
--
-- > mconcatE [ [|x|], [|y|], [|z|] ] = [| x <> (y <> z) |]
mconcatE :: [ExpQ] -> ExpQ
mconcatE :: [Q Exp] -> Q Exp
mconcatE [] = [|Monoid.mempty|]
mconcatE [Q Exp
x] = Q Exp
x
mconcatE (Q Exp
x : [Q Exp]
xs) = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
x [|(Monoid.<>)|] ([Q Exp] -> Q Exp
mconcatE [Q Exp]
xs)

fromPairsE :: ToJSONFun -> ExpQ -> ExpQ
fromPairsE :: ToJSONFun -> Q Exp -> Q Exp
fromPairsE ToJSONFun
_ = ([|fromPairs|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`)

-- | Create (an encoding of) a key-value pair.
--
-- > pairE "k" [|v|] = [| pair "k" v |]
--
pairE :: LetInsert -> ToJSONFun -> String -> ExpQ -> ExpQ
pairE :: (ShortByteString -> Q Exp) -> ToJSONFun -> String -> Q Exp -> Q Exp
pairE ShortByteString -> Q Exp
letInsert ToJSONFun
Encoding String
k Q Exp
v = [| E.unsafePairSBS |] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ShortByteString -> Q Exp
letInsert ShortByteString
k' forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
v
  where
    k' :: ShortByteString
k' = ShortText -> ShortByteString
ST.toShortByteString forall a b. (a -> b) -> a -> b
$ String -> ShortText
ST.pack forall a b. (a -> b) -> a -> b
$ String
"\"" forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
escapeAscii String
k forall a. [a] -> [a] -> [a]
++ String
"\":"

    escapeAscii :: Char -> String
escapeAscii Char
'\\' = String
"\\\\"
    escapeAscii Char
'\"' = String
"\\\""
    escapeAscii Char
'\n' = String
"\\n"
    escapeAscii Char
'\r' = String
"\\r"
    escapeAscii Char
'\t' = String
"\\t"
    escapeAscii Char
c
      | Char -> Int
ord Char
c forall a. Ord a => a -> a -> Bool
< Int
0x20 = String
"\\u" forall a. [a] -> [a] -> [a]
++ forall r. PrintfType r => String -> r
printf String
"%04x" (Char -> Int
ord Char
c)
    escapeAscii Char
c    = [Char
c]

pairE ShortByteString -> Q Exp
_letInsert ToJSONFun
Value    String
k Q Exp
v = [| pair (Key.fromString k) |] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
v

--------------------------------------------------------------------------------
-- FromJSON
--------------------------------------------------------------------------------

-- | Generates a 'FromJSON' instance declaration for the given data type or
-- data family instance constructor.
deriveFromJSON :: Options
               -- ^ Encoding options.
               -> Name
               -- ^ Name of the type for which to generate a 'FromJSON' instance
               -- declaration.
               -> Q [Dec]
deriveFromJSON :: Options -> Name -> Q [Dec]
deriveFromJSON = JSONClass -> Options -> Name -> Q [Dec]
deriveFromJSONCommon JSONClass
fromJSONClass

-- | Generates a 'FromJSON1' instance declaration for the given data type or
-- data family instance constructor.
deriveFromJSON1 :: Options
                -- ^ Encoding options.
                -> Name
                -- ^ Name of the type for which to generate a 'FromJSON1' instance
                -- declaration.
                -> Q [Dec]
deriveFromJSON1 :: Options -> Name -> Q [Dec]
deriveFromJSON1 = JSONClass -> Options -> Name -> Q [Dec]
deriveFromJSONCommon JSONClass
fromJSON1Class

-- | Generates a 'FromJSON2' instance declaration for the given data type or
-- data family instance constructor.
deriveFromJSON2 :: Options
                -- ^ Encoding options.
                -> Name
                -- ^ Name of the type for which to generate a 'FromJSON3' instance
                -- declaration.
                -> Q [Dec]
deriveFromJSON2 :: Options -> Name -> Q [Dec]
deriveFromJSON2 = JSONClass -> Options -> Name -> Q [Dec]
deriveFromJSONCommon JSONClass
fromJSON2Class

deriveFromJSONCommon :: JSONClass
                     -- ^ The FromJSON variant being derived.
                     -> Options
                     -- ^ Encoding options.
                     -> Name
                     -- ^ Name of the type for which to generate an instance.
                     -- declaration.
                     -> Q [Dec]
deriveFromJSONCommon :: JSONClass -> Options -> Name -> Q [Dec]
deriveFromJSONCommon = [(JSONFun,
  JSONClass
  -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)]
-> JSONClass -> Options -> Name -> Q [Dec]
deriveJSONClass [(JSONFun
ParseJSON, JSONClass
-> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
consFromJSON)]

-- | Generates a lambda expression which parses the JSON encoding of the given
-- data type or data family instance constructor.
mkParseJSON :: Options -- ^ Encoding options.
            -> Name -- ^ Name of the encoded type.
            -> Q Exp
mkParseJSON :: Options -> Name -> Q Exp
mkParseJSON = JSONClass -> Options -> Name -> Q Exp
mkParseJSONCommon JSONClass
fromJSONClass

-- | Generates a lambda expression which parses the JSON encoding of the given
-- data type or data family instance constructor by using the given parsing
-- function on occurrences of the last type parameter.
mkLiftParseJSON :: Options -- ^ Encoding options.
                -> Name -- ^ Name of the encoded type.
                -> Q Exp
mkLiftParseJSON :: Options -> Name -> Q Exp
mkLiftParseJSON = JSONClass -> Options -> Name -> Q Exp
mkParseJSONCommon JSONClass
fromJSON1Class

-- | Generates a lambda expression which parses the JSON encoding of the given
-- data type or data family instance constructor by using the given parsing
-- functions on occurrences of the last two type parameters.
mkLiftParseJSON2 :: Options -- ^ Encoding options.
                 -> Name -- ^ Name of the encoded type.
                 -> Q Exp
mkLiftParseJSON2 :: Options -> Name -> Q Exp
mkLiftParseJSON2 = JSONClass -> Options -> Name -> Q Exp
mkParseJSONCommon JSONClass
fromJSON2Class

mkParseJSONCommon :: JSONClass -- ^ Which class's method is being derived.
                  -> Options -- ^ Encoding options.
                  -> Name -- ^ Name of the encoded type.
                  -> Q Exp
mkParseJSONCommon :: JSONClass -> Options -> Name -> Q Exp
mkParseJSONCommon = (JSONClass
 -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
-> JSONClass -> Options -> Name -> Q Exp
mkFunCommon JSONClass
-> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
consFromJSON

-- | Helper function used by both 'deriveFromJSON' and 'mkParseJSON'. Generates
-- code to parse the JSON encoding of a number of constructors. All constructors
-- must be from the same type.
consFromJSON :: JSONClass
             -- ^ The FromJSON variant being derived.
             -> Name
             -- ^ Name of the type to which the constructors belong.
             -> Options
             -- ^ Encoding options
             -> [Type]
             -- ^ The types from the data type/data family instance declaration
             -> [ConstructorInfo]
             -- ^ Constructors for which to generate JSON parsing code.
             -> Q Exp

consFromJSON :: JSONClass
-> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
consFromJSON JSONClass
_ Name
_ Options
_ [Type]
_ [] =
    [| \_ -> fail "Attempted to parse empty type" |]

consFromJSON JSONClass
jc Name
tName Options
opts [Type]
instTys [ConstructorInfo]
cons = do
  Name
value <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"value"
  [Name]
pjs   <- String -> Int -> Q [Name]
newNameList String
"_pj"  forall a b. (a -> b) -> a -> b
$ JSONClass -> Int
arityInt JSONClass
jc
  [Name]
pjls  <- String -> Int -> Q [Name]
newNameList String
"_pjl" forall a b. (a -> b) -> a -> b
$ JSONClass -> Int
arityInt JSONClass
jc
  let zippedPJs :: [(Name, Name)]
zippedPJs      = forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
pjs [Name]
pjls
      interleavedPJs :: [Name]
interleavedPJs = forall a. [a] -> [a] -> [a]
interleave [Name]
pjs [Name]
pjls
      lastTyVars :: [Name]
lastTyVars     = forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
instTys forall a. Num a => a -> a -> a
- JSONClass -> Int
arityInt JSONClass
jc) [Type]
instTys
      tvMap :: Map Name (Name, Name)
tvMap          = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
lastTyVars [(Name, Name)]
zippedPJs
  forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP forall a b. (a -> b) -> a -> b
$ [Name]
interleavedPJs forall a. [a] -> [a] -> [a]
++ [Name
value]) forall a b. (a -> b) -> a -> b
$ Name -> Map Name (Name, Name) -> Q Exp
lamExpr Name
value Map Name (Name, Name)
tvMap

  where
    checkExi :: Map Name (Name, Name) -> ConstructorInfo -> Q a -> Q a
checkExi Map Name (Name, Name)
tvMap ConstructorInfo
con = forall a.
JSONClass -> Map Name (Name, Name) -> [Type] -> Name -> Q a -> Q a
checkExistentialContext JSONClass
jc Map Name (Name, Name)
tvMap
                                                 (ConstructorInfo -> [Type]
constructorContext ConstructorInfo
con)
                                                 (ConstructorInfo -> Name
constructorName ConstructorInfo
con)

    lamExpr :: Name -> Map Name (Name, Name) -> Q Exp
lamExpr Name
value Map Name (Name, Name)
tvMap = case [ConstructorInfo]
cons of
      [ConstructorInfo
con]
        | Bool -> Bool
not (Options -> Bool
tagSingleConstructors Options
opts)
            -> forall {a}. Map Name (Name, Name) -> ConstructorInfo -> Q a -> Q a
checkExi Map Name (Name, Name)
tvMap ConstructorInfo
con forall a b. (a -> b) -> a -> b
$ JSONClass
-> Map Name (Name, Name)
-> Name
-> Options
-> ConstructorInfo
-> Either (String, Name) Name
-> Q Exp
parseArgs JSONClass
jc Map Name (Name, Name)
tvMap Name
tName Options
opts ConstructorInfo
con (forall a b. b -> Either a b
Right Name
value)
      [ConstructorInfo]
_ | Options -> SumEncoding
sumEncoding Options
opts forall a. Eq a => a -> a -> Bool
== SumEncoding
UntaggedValue
            -> Map Name (Name, Name) -> [ConstructorInfo] -> Name -> Q Exp
parseUntaggedValue Map Name (Name, Name)
tvMap [ConstructorInfo]
cons Name
value
        | Bool
otherwise
            -> forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value) forall a b. (a -> b) -> a -> b
$
                   if Options -> Bool
allNullaryToStringTag Options
opts Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ConstructorInfo -> Bool
isNullary [ConstructorInfo]
cons
                   then [Q Match]
allNullaryMatches
                   else Map Name (Name, Name) -> [Q Match]
mixedMatches Map Name (Name, Name)
tvMap

    allNullaryMatches :: [Q Match]
allNullaryMatches =
      [ do Name
txt <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"txtX"
           forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'String [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
txt])
                 (forall (m :: * -> *). Quote m => [m (Guard, Exp)] -> m Body
guardedB forall a b. (a -> b) -> a -> b
$
                  [ forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (forall (m :: * -> *). Quote m => m Exp -> m Guard
normalG forall a b. (a -> b) -> a -> b
$
                                  forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
txt)
                                           [|(==)|]
                                           (Options -> Name -> Q Exp
conTxt Options
opts Name
conName)
                               )
                               ([|pure|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName)
                  | ConstructorInfo
con <- [ConstructorInfo]
cons
                  , let conName :: Name
conName = ConstructorInfo -> Name
constructorName ConstructorInfo
con
                  ]
                  forall a. [a] -> [a] -> [a]
++
                  [ forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,)
                      (forall (m :: * -> *). Quote m => m Exp -> m Guard
normalG [|otherwise|])
                      ( [|noMatchFail|]
                        forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Name
tName)
                        forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ([|T.unpack|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
txt)
                      )
                  ]
                 )
                 []
      , do Name
other <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"other"
           forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
other)
                 (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ [|noStringFail|]
                    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Name
tName)
                    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ([|valueConName|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
other)
                 )
                 []
      ]

    mixedMatches :: Map Name (Name, Name) -> [Q Match]
mixedMatches Map Name (Name, Name)
tvMap =
        case Options -> SumEncoding
sumEncoding Options
opts of
          TaggedObject {String
tagFieldName :: String
tagFieldName :: SumEncoding -> String
tagFieldName, String
contentsFieldName :: String
contentsFieldName :: SumEncoding -> String
contentsFieldName} ->
            forall {m :: * -> *}. Quote m => (Name -> m Exp) -> [m Match]
parseObject forall a b. (a -> b) -> a -> b
$ Map Name (Name, Name) -> String -> String -> Name -> Q Exp
parseTaggedObject Map Name (Name, Name)
tvMap String
tagFieldName String
contentsFieldName
          SumEncoding
UntaggedValue -> forall a. HasCallStack => String -> a
error String
"UntaggedValue: Should be handled already"
          SumEncoding
ObjectWithSingleField ->
            forall {m :: * -> *}. Quote m => (Name -> m Exp) -> [m Match]
parseObject forall a b. (a -> b) -> a -> b
$ Map Name (Name, Name) -> Name -> Q Exp
parseObjectWithSingleField Map Name (Name, Name)
tvMap
          SumEncoding
TwoElemArray ->
            [ do Name
arr <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"array"
                 forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Array [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
arr])
                       (forall (m :: * -> *). Quote m => [m (Guard, Exp)] -> m Body
guardedB
                        [ forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (forall (m :: * -> *). Quote m => m Exp -> m Guard
normalG forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp ([|V.length|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
arr)
                                                         [|(==)|]
                                                         (forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall a b. (a -> b) -> a -> b
$ Integer -> Lit
integerL Integer
2))
                                     (Map Name (Name, Name) -> Name -> Q Exp
parse2ElemArray Map Name (Name, Name)
tvMap Name
arr)
                        , forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (forall (m :: * -> *). Quote m => m Exp -> m Guard
normalG [|otherwise|])
                                     ([|not2ElemArray|]
                                       forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Name
tName)
                                       forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ([|V.length|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
arr))
                        ]
                       )
                       []
            , do Name
other <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"other"
                 forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
other)
                       ( forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                         forall a b. (a -> b) -> a -> b
$ [|noArrayFail|]
                             forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Name
tName)
                             forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ([|valueConName|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
other)
                       )
                       []
            ]

    parseObject :: (Name -> m Exp) -> [m Match]
parseObject Name -> m Exp
f =
        [ do Name
obj <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"obj"
             forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Object [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
obj]) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ Name -> m Exp
f Name
obj) []
        , do Name
other <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"other"
             forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
other)
                   ( forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                     forall a b. (a -> b) -> a -> b
$ [|noObjectFail|]
                         forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Name
tName)
                         forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ([|valueConName|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
other)
                   )
                   []
        ]

    parseTaggedObject :: Map Name (Name, Name) -> String -> String -> Name -> Q Exp
parseTaggedObject Map Name (Name, Name)
tvMap String
typFieldName String
valFieldName Name
obj = do
      Name
conKey <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"conKeyX"
      forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
doE [ forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
bindS (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
conKey)
                  (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
obj)
                            [|(.:)|]
                            ([|Key.fromString|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => String -> m Exp
stringE String
typFieldName))
          , forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS forall a b. (a -> b) -> a -> b
$ Map Name (Name, Name)
-> Name
-> Either (String, Name) Name
-> Name
-> Q Exp
-> Q Exp
-> Q Exp
parseContents Map Name (Name, Name)
tvMap Name
conKey (forall a b. a -> Either a b
Left (String
valFieldName, Name
obj)) 'conNotFoundFailTaggedObject [|Key.fromString|] [|Key.toString|]
          ]

    parseUntaggedValue :: Map Name (Name, Name) -> [ConstructorInfo] -> Name -> Q Exp
parseUntaggedValue Map Name (Name, Name)
tvMap [ConstructorInfo]
cons' Name
conVal =
        forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Q Exp
e Q Exp
e' -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
e [|(<|>)|] Q Exp
e')
               (forall a b. (a -> b) -> [a] -> [b]
map (\ConstructorInfo
x -> Map Name (Name, Name) -> ConstructorInfo -> Name -> Q Exp
parseValue Map Name (Name, Name)
tvMap ConstructorInfo
x Name
conVal) [ConstructorInfo]
cons')

    parseValue :: Map Name (Name, Name) -> ConstructorInfo -> Name -> Q Exp
parseValue Map Name (Name, Name)
_tvMap
        ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                        , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
NormalConstructor
                        , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [] }
        Name
conVal = do
      Name
str <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"str"
      forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
conVal)
        [ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'String [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
str])
                (forall (m :: * -> *). Quote m => [m (Guard, Exp)] -> m Body
guardedB
                  [ forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (forall (m :: * -> *). Quote m => m Exp -> m Guard
normalG forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
str) [|(==)|] (Options -> Name -> Q Exp
conTxt Options
opts Name
conName)
                               )
                               ([|pure|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName)
                  ]
                )
                []
        , Name -> Name -> String -> Q Match
matchFailed Name
tName Name
conName String
"String"
        ]
    parseValue Map Name (Name, Name)
tvMap ConstructorInfo
con Name
conVal =
      forall {a}. Map Name (Name, Name) -> ConstructorInfo -> Q a -> Q a
checkExi Map Name (Name, Name)
tvMap ConstructorInfo
con forall a b. (a -> b) -> a -> b
$ JSONClass
-> Map Name (Name, Name)
-> Name
-> Options
-> ConstructorInfo
-> Either (String, Name) Name
-> Q Exp
parseArgs JSONClass
jc Map Name (Name, Name)
tvMap Name
tName Options
opts ConstructorInfo
con (forall a b. b -> Either a b
Right Name
conVal)


    parse2ElemArray :: Map Name (Name, Name) -> Name -> Q Exp
parse2ElemArray Map Name (Name, Name)
tvMap Name
arr = do
      Name
conKey <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"conKeyY"
      Name
conVal <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"conValY"
      let letIx :: Name -> Integer -> m Dec
letIx Name
n Integer
ix =
              forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
n)
                   (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ([|V.unsafeIndex|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
                               forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
arr forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
                               forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Integer -> Lit
integerL Integer
ix)))
                   []
      forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE [ forall {m :: * -> *}. Quote m => Name -> Integer -> m Dec
letIx Name
conKey Integer
0
           , forall {m :: * -> *}. Quote m => Name -> Integer -> m Dec
letIx Name
conVal Integer
1
           ]
           (forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
conKey)
                  [ do Name
txt <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"txtY"
                       forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'String [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
txt])
                             (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ Map Name (Name, Name)
-> Name
-> Either (String, Name) Name
-> Name
-> Q Exp
-> Q Exp
-> Q Exp
parseContents Map Name (Name, Name)
tvMap
                                                      Name
txt
                                                      (forall a b. b -> Either a b
Right Name
conVal)
                                                      'conNotFoundFail2ElemArray
                                                      [|T.pack|] [|T.unpack|]
                             )
                             []
                  , do Name
other <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"other"
                       forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
other)
                             ( forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                               forall a b. (a -> b) -> a -> b
$ [|firstElemNoStringFail|]
                                     forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Name
tName)
                                     forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ([|valueConName|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
other)
                             )
                             []
                  ]
           )

    parseObjectWithSingleField :: Map Name (Name, Name) -> Name -> Q Exp
parseObjectWithSingleField Map Name (Name, Name)
tvMap Name
obj = do
      Name
conKey <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"conKeyZ"
      Name
conVal <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"conValZ"
      forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE ([e|KM.toList|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
obj)
            [ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => [m Pat] -> m Pat
listP [forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
conKey, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
conVal]])
                    (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ Map Name (Name, Name)
-> Name
-> Either (String, Name) Name
-> Name
-> Q Exp
-> Q Exp
-> Q Exp
parseContents Map Name (Name, Name)
tvMap Name
conKey (forall a b. b -> Either a b
Right Name
conVal) 'conNotFoundFailObjectSingleField [|Key.fromString|] [|Key.toString|])
                    []
            , do Name
other <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"other"
                 forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
other)
                       (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ [|wrongPairCountFail|]
                                  forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Name
tName)
                                  forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ([|show . length|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
other)
                       )
                       []
            ]

    parseContents :: Map Name (Name, Name)
-> Name
-> Either (String, Name) Name
-> Name
-> Q Exp
-> Q Exp
-> Q Exp
parseContents Map Name (Name, Name)
tvMap Name
conKey Either (String, Name) Name
contents Name
errorFun Q Exp
pack Q Exp
unpack=
        forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
conKey)
              [ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match forall (m :: * -> *). Quote m => m Pat
wildP
                      ( forall (m :: * -> *). Quote m => [m (Guard, Exp)] -> m Body
guardedB forall a b. (a -> b) -> a -> b
$
                        [ do Guard
g <- forall (m :: * -> *). Quote m => m Exp -> m Guard
normalG forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
conKey)
                                                     [|(==)|]
                                                     (Q Exp
pack forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
                                                        Options -> ConstructorInfo -> Q Exp
conNameExp Options
opts ConstructorInfo
con)
                             Exp
e <- forall {a}. Map Name (Name, Name) -> ConstructorInfo -> Q a -> Q a
checkExi Map Name (Name, Name)
tvMap ConstructorInfo
con forall a b. (a -> b) -> a -> b
$
                                  JSONClass
-> Map Name (Name, Name)
-> Name
-> Options
-> ConstructorInfo
-> Either (String, Name) Name
-> Q Exp
parseArgs JSONClass
jc Map Name (Name, Name)
tvMap Name
tName Options
opts ConstructorInfo
con Either (String, Name) Name
contents
                             forall (m :: * -> *) a. Monad m => a -> m a
return (Guard
g, Exp
e)
                        | ConstructorInfo
con <- [ConstructorInfo]
cons
                        ]
                        forall a. [a] -> [a] -> [a]
++
                        [ forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,)
                                 (forall (m :: * -> *). Quote m => m Exp -> m Guard
normalG [e|otherwise|])
                                 ( forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
errorFun
                                   forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Name
tName)
                                   forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE (forall a b. (a -> b) -> [a] -> [b]
map ( forall (m :: * -> *). Quote m => Lit -> m Exp
litE
                                                     forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
stringL
                                                     forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> String -> String
constructorTagModifier Options
opts
                                                     forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
                                                     forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorInfo -> Name
constructorName
                                                     ) [ConstructorInfo]
cons
                                                )
                                   forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (Q Exp
unpack forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
conKey)
                                 )
                        ]
                      )
                      []
              ]

parseNullaryMatches :: Name -> Name -> [Q Match]
parseNullaryMatches :: Name -> Name -> [Q Match]
parseNullaryMatches Name
tName Name
conName =
    [ do Name
arr <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"arr"
         forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Array [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
arr])
               (forall (m :: * -> *). Quote m => [m (Guard, Exp)] -> m Body
guardedB
                [ forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (forall (m :: * -> *). Quote m => m Exp -> m Guard
normalG forall a b. (a -> b) -> a -> b
$ [|V.null|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
arr)
                             ([|pure|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName)
                , forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (forall (m :: * -> *). Quote m => m Exp -> m Guard
normalG [|otherwise|])
                             (Name -> Name -> Q Exp -> Q Exp -> Q Exp
parseTypeMismatch Name
tName Name
conName
                                (forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL String
"an empty Array")
                                (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL String
"Array of length ")
                                          [|(++)|]
                                          ([|show . V.length|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
arr)
                                )
                             )
                ]
               )
               []
    , Name -> Name -> String -> Q Match
matchFailed Name
tName Name
conName String
"Array"
    ]

parseUnaryMatches :: JSONClass -> TyVarMap -> Type -> Name -> [Q Match]
parseUnaryMatches :: JSONClass -> Map Name (Name, Name) -> Type -> Name -> [Q Match]
parseUnaryMatches JSONClass
jc Map Name (Name, Name)
tvMap Type
argTy Name
conName =
    [ do Name
arg <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"arg"
         forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
arg)
               ( forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName)
                                    [|(<$>)|]
                                    (JSONClass -> Name -> Map Name (Name, Name) -> Type -> Q Exp
dispatchParseJSON JSONClass
jc Name
conName Map Name (Name, Name)
tvMap Type
argTy
                                      forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
arg)
               )
               []
    ]

parseRecord :: JSONClass
            -> TyVarMap
            -> [Type]
            -> Options
            -> Name
            -> Name
            -> [Name]
            -> Name
            -> Bool
            -> ExpQ
parseRecord :: JSONClass
-> Map Name (Name, Name)
-> [Type]
-> Options
-> Name
-> Name
-> [Name]
-> Name
-> Bool
-> Q Exp
parseRecord JSONClass
jc Map Name (Name, Name)
tvMap [Type]
argTys Options
opts Name
tName Name
conName [Name]
fields Name
obj Bool
inTaggedObject =
    (if Options -> Bool
rejectUnknownFields Options
opts
     then forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
checkUnknownRecords [|(>>)|]
     else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Q Exp
a Q Exp
b -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
a [|(<*>)|] Q Exp
b)
           (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName) [|(<$>)|] Q Exp
x)
           [Q Exp]
xs
    where
      tagFieldNameAppender :: [String] -> [String]
tagFieldNameAppender =
          if Bool
inTaggedObject then (SumEncoding -> String
tagFieldName (Options -> SumEncoding
sumEncoding Options
opts) forall a. a -> [a] -> [a]
:) else forall a. a -> a
id
      knownFields :: Q Exp
knownFields = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|KM.fromList|] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$
          forall a b. (a -> b) -> [a] -> [b]
map (\String
knownName -> forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE [forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|Key.fromString|] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL String
knownName, [|()|]]) forall a b. (a -> b) -> a -> b
$
              [String] -> [String]
tagFieldNameAppender forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Options -> Name -> String
fieldLabel Options
opts) [Name]
fields
      checkUnknownRecords :: Q Exp
checkUnknownRecords =
          forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|KM.keys|] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
obj) [|KM.difference|] Q Exp
knownFields)
              [ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => [m Pat] -> m Pat
listP []) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|return ()|]) []
              , forall (m :: * -> *). Quote m => String -> m Name
newName String
"unknownFields" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                  \Name
unknownFields -> forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
unknownFields)
                      (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|fail|] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp
                          (forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL String
"Unknown fields: "))
                          [|(++)|]
                          (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|show|] (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
unknownFields)))
                      []
              ]
      Q Exp
x:[Q Exp]
xs = [ [|lookupField|]
               forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` JSONClass -> Name -> Map Name (Name, Name) -> Type -> Q Exp
dispatchParseJSON JSONClass
jc Name
conName Map Name (Name, Name)
tvMap Type
argTy
               forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Name
tName)
               forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL forall a b. (a -> b) -> a -> b
$ Options -> String -> String
constructorTagModifier Options
opts forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
conName)
               forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
obj
               forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ( [|Key.fromString|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => String -> m Exp
stringE (Options -> Name -> String
fieldLabel Options
opts Name
field)
                      )
             | (Name
field, Type
argTy) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
fields [Type]
argTys
             ]

getValField :: Name -> String -> [MatchQ] -> Q Exp
getValField :: Name -> String -> [Q Match] -> Q Exp
getValField Name
obj String
valFieldName [Q Match]
matches = do
  Name
val <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"val"
  forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
doE [ forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
bindS (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
val) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
obj)
                                    [|(.:)|]
                                    ([|Key.fromString|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
                                       forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL String
valFieldName))
      , forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
val) [Q Match]
matches
      ]

matchCases :: Either (String, Name) Name -> [MatchQ] -> Q Exp
matchCases :: Either (String, Name) Name -> [Q Match] -> Q Exp
matchCases (Left (String
valFieldName, Name
obj)) = Name -> String -> [Q Match] -> Q Exp
getValField Name
obj String
valFieldName
matchCases (Right Name
valName)            = forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
valName)

-- | Generates code to parse the JSON encoding of a single constructor.
parseArgs :: JSONClass -- ^ The FromJSON variant being derived.
          -> TyVarMap -- ^ Maps the last type variables to their decoding
                      --   function arguments.
          -> Name -- ^ Name of the type to which the constructor belongs.
          -> Options -- ^ Encoding options.
          -> ConstructorInfo -- ^ Constructor for which to generate JSON parsing code.
          -> Either (String, Name) Name -- ^ Left (valFieldName, objName) or
                                        --   Right valName
          -> Q Exp
-- Nullary constructors.
parseArgs :: JSONClass
-> Map Name (Name, Name)
-> Name
-> Options
-> ConstructorInfo
-> Either (String, Name) Name
-> Q Exp
parseArgs JSONClass
_ Map Name (Name, Name)
_ Name
_ Options
_
  ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                  , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
NormalConstructor
                  , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [] }
  (Left (String, Name)
_) =
    [|pure|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName
parseArgs JSONClass
_ Map Name (Name, Name)
_ Name
tName Options
_
  ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                  , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
NormalConstructor
                  , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [] }
  (Right Name
valName) =
    forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
valName) forall a b. (a -> b) -> a -> b
$ Name -> Name -> [Q Match]
parseNullaryMatches Name
tName Name
conName

-- Unary constructors.
parseArgs JSONClass
jc Map Name (Name, Name)
tvMap Name
_ Options
_
  ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                  , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
NormalConstructor
                  , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type
argTy] }
  Either (String, Name) Name
contents = do
    Type
argTy' <- Type -> Q Type
resolveTypeSynonyms Type
argTy
    Either (String, Name) Name -> [Q Match] -> Q Exp
matchCases Either (String, Name) Name
contents forall a b. (a -> b) -> a -> b
$ JSONClass -> Map Name (Name, Name) -> Type -> Name -> [Q Match]
parseUnaryMatches JSONClass
jc Map Name (Name, Name)
tvMap Type
argTy' Name
conName

-- Polyadic constructors.
parseArgs JSONClass
jc Map Name (Name, Name)
tvMap Name
tName Options
_
  ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                  , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
NormalConstructor
                  , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
argTys }
  Either (String, Name) Name
contents = do
    [Type]
argTys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms [Type]
argTys
    let len :: Integer
len = forall i a. Num i => [a] -> i
genericLength [Type]
argTys'
    Either (String, Name) Name -> [Q Match] -> Q Exp
matchCases Either (String, Name) Name
contents forall a b. (a -> b) -> a -> b
$ JSONClass
-> Map Name (Name, Name)
-> [Type]
-> Name
-> Name
-> Integer
-> [Q Match]
parseProduct JSONClass
jc Map Name (Name, Name)
tvMap [Type]
argTys' Name
tName Name
conName Integer
len

-- Records.
parseArgs JSONClass
jc Map Name (Name, Name)
tvMap Name
tName Options
opts
  ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                  , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = RecordConstructor [Name]
fields
                  , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
argTys }
  (Left (String
_, Name
obj)) = do
    [Type]
argTys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms [Type]
argTys
    JSONClass
-> Map Name (Name, Name)
-> [Type]
-> Options
-> Name
-> Name
-> [Name]
-> Name
-> Bool
-> Q Exp
parseRecord JSONClass
jc Map Name (Name, Name)
tvMap [Type]
argTys' Options
opts Name
tName Name
conName [Name]
fields Name
obj Bool
True
parseArgs JSONClass
jc Map Name (Name, Name)
tvMap Name
tName Options
opts
  info :: ConstructorInfo
info@ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                       , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = RecordConstructor [Name]
fields
                       , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
argTys }
  (Right Name
valName) =
    case (Options -> Bool
unwrapUnaryRecords Options
opts,[Type]
argTys) of
      (Bool
True,[Type
_])-> JSONClass
-> Map Name (Name, Name)
-> Name
-> Options
-> ConstructorInfo
-> Either (String, Name) Name
-> Q Exp
parseArgs JSONClass
jc Map Name (Name, Name)
tvMap Name
tName Options
opts
                             (ConstructorInfo
info{constructorVariant :: ConstructorVariant
constructorVariant = ConstructorVariant
NormalConstructor})
                             (forall a b. b -> Either a b
Right Name
valName)
      (Bool, [Type])
_ -> do
        Name
obj <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"recObj"
        [Type]
argTys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms [Type]
argTys
        forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
valName)
          [ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Object [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
obj]) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$
              JSONClass
-> Map Name (Name, Name)
-> [Type]
-> Options
-> Name
-> Name
-> [Name]
-> Name
-> Bool
-> Q Exp
parseRecord JSONClass
jc Map Name (Name, Name)
tvMap [Type]
argTys' Options
opts Name
tName Name
conName [Name]
fields Name
obj Bool
False) []
          , Name -> Name -> String -> Q Match
matchFailed Name
tName Name
conName String
"Object"
          ]

-- Infix constructors. Apart from syntax these are the same as
-- polyadic constructors.
parseArgs JSONClass
jc Map Name (Name, Name)
tvMap Name
tName Options
_
  ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                  , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
InfixConstructor
                  , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
argTys }
  Either (String, Name) Name
contents = do
    [Type]
argTys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms [Type]
argTys
    Either (String, Name) Name -> [Q Match] -> Q Exp
matchCases Either (String, Name) Name
contents forall a b. (a -> b) -> a -> b
$ JSONClass
-> Map Name (Name, Name)
-> [Type]
-> Name
-> Name
-> Integer
-> [Q Match]
parseProduct JSONClass
jc Map Name (Name, Name)
tvMap [Type]
argTys' Name
tName Name
conName Integer
2

-- | Generates code to parse the JSON encoding of an n-ary
-- constructor.
parseProduct :: JSONClass -- ^ The FromJSON variant being derived.
             -> TyVarMap -- ^ Maps the last type variables to their decoding
                         --   function arguments.
             -> [Type] -- ^ The argument types of the constructor.
             -> Name -- ^ Name of the type to which the constructor belongs.
             -> Name -- ^ 'Con'structor name.
             -> Integer -- ^ 'Con'structor arity.
             -> [Q Match]
parseProduct :: JSONClass
-> Map Name (Name, Name)
-> [Type]
-> Name
-> Name
-> Integer
-> [Q Match]
parseProduct JSONClass
jc Map Name (Name, Name)
tvMap [Type]
argTys Name
tName Name
conName Integer
numArgs =
    [ do Name
arr <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"arr"
         -- List of: "parseJSON (arr `V.unsafeIndex` <IX>)"
         let Q Exp
x:[Q Exp]
xs = [ JSONClass -> Name -> Map Name (Name, Name) -> Type -> Q Exp
dispatchParseJSON JSONClass
jc Name
conName Map Name (Name, Name)
tvMap Type
argTy
                      forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
                      forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
arr)
                               [|V.unsafeIndex|]
                               (forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall a b. (a -> b) -> a -> b
$ Integer -> Lit
integerL Integer
ix)
                    | (Type
argTy, Integer
ix) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
argTys [Integer
0 .. Integer
numArgs forall a. Num a => a -> a -> a
- Integer
1]
                    ]
         forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Array [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
arr])
               (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
condE ( forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp ([|V.length|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
arr)
                                           [|(==)|]
                                           (forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall a b. (a -> b) -> a -> b
$ Integer -> Lit
integerL Integer
numArgs)
                                )
                                ( forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Q Exp
a Q Exp
b -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
a [|(<*>)|] Q Exp
b)
                                         (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName) [|(<$>)|] Q Exp
x)
                                         [Q Exp]
xs
                                )
                                ( Name -> Name -> Q Exp -> Q Exp -> Q Exp
parseTypeMismatch Name
tName Name
conName
                                    (forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL forall a b. (a -> b) -> a -> b
$ String
"Array of length " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
numArgs)
                                    ( forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL String
"Array of length ")
                                               [|(++)|]
                                               ([|show . V.length|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
arr)
                                    )
                                )
               )
               []
    , Name -> Name -> String -> Q Match
matchFailed Name
tName Name
conName String
"Array"
    ]

--------------------------------------------------------------------------------
-- Parsing errors
--------------------------------------------------------------------------------

matchFailed :: Name -> Name -> String -> MatchQ
matchFailed :: Name -> Name -> String -> Q Match
matchFailed Name
tName Name
conName String
expected = do
  Name
other <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"other"
  forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
other)
        ( forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ Name -> Name -> Q Exp -> Q Exp -> Q Exp
parseTypeMismatch Name
tName Name
conName
                      (forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL String
expected)
                      ([|valueConName|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
other)
        )
        []

parseTypeMismatch :: Name -> Name -> ExpQ -> ExpQ -> ExpQ
parseTypeMismatch :: Name -> Name -> Q Exp -> Q Exp -> Q Exp
parseTypeMismatch Name
tName Name
conName Q Exp
expected Q Exp
actual =
    forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
          [|parseTypeMismatch'|]
          [ forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
conName
          , forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Name
tName
          , Q Exp
expected
          , Q Exp
actual
          ]

class LookupField a where
    lookupField :: (Value -> Parser a) -> String -> String
                -> Object -> Key -> Parser a

instance {-# OVERLAPPABLE #-} LookupField a where
    lookupField :: (Value -> Parser a)
-> String -> String -> Object -> Key -> Parser a
lookupField = forall a.
(Value -> Parser a)
-> String -> String -> Object -> Key -> Parser a
lookupFieldWith

instance {-# INCOHERENT #-} LookupField (Maybe a) where
    lookupField :: (Value -> Parser (Maybe a))
-> String -> String -> Object -> Key -> Parser (Maybe a)
lookupField Value -> Parser (Maybe a)
pj String
_ String
_ = forall a.
(Value -> Parser (Maybe a)) -> Object -> Key -> Parser (Maybe a)
parseOptionalFieldWith Value -> Parser (Maybe a)
pj

#if !MIN_VERSION_base(4,16,0)
instance {-# INCOHERENT #-} LookupField (Semigroup.Option a) where
    lookupField pj tName rec obj key =
        fmap Semigroup.Option
             (lookupField (fmap Semigroup.getOption . pj) tName rec obj key)
#endif

lookupFieldWith :: (Value -> Parser a) -> String -> String
                -> Object -> Key -> Parser a
lookupFieldWith :: forall a.
(Value -> Parser a)
-> String -> String -> Object -> Key -> Parser a
lookupFieldWith Value -> Parser a
pj String
tName String
rec Object
obj Key
key =
    case forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
key Object
obj of
      Maybe Value
Nothing -> forall fail. String -> String -> String -> Parser fail
unknownFieldFail String
tName String
rec (Key -> String
Key.toString Key
key)
      Just Value
v  -> Value -> Parser a
pj Value
v forall a. Parser a -> JSONPathElement -> Parser a
<?> Key -> JSONPathElement
Key Key
key

unknownFieldFail :: String -> String -> String -> Parser fail
unknownFieldFail :: forall fail. String -> String -> String -> Parser fail
unknownFieldFail String
tName String
rec String
key =
    forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"When parsing the record %s of type %s the key %s was not present."
                  String
rec String
tName String
key

noArrayFail :: String -> String -> Parser fail
noArrayFail :: forall fail. String -> String -> Parser fail
noArrayFail String
t String
o = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"When parsing %s expected Array but got %s." String
t String
o

noObjectFail :: String -> String -> Parser fail
noObjectFail :: forall fail. String -> String -> Parser fail
noObjectFail String
t String
o = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"When parsing %s expected Object but got %s." String
t String
o

firstElemNoStringFail :: String -> String -> Parser fail
firstElemNoStringFail :: forall fail. String -> String -> Parser fail
firstElemNoStringFail String
t String
o = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"When parsing %s expected an Array of 2 elements where the first element is a String but got %s at the first element." String
t String
o

wrongPairCountFail :: String -> String -> Parser fail
wrongPairCountFail :: forall fail. String -> String -> Parser fail
wrongPairCountFail String
t String
n =
    forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"When parsing %s expected an Object with a single tag/contents pair but got %s pairs."
                  String
t String
n

noStringFail :: String -> String -> Parser fail
noStringFail :: forall fail. String -> String -> Parser fail
noStringFail String
t String
o = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"When parsing %s expected String but got %s." String
t String
o

noMatchFail :: String -> String -> Parser fail
noMatchFail :: forall fail. String -> String -> Parser fail
noMatchFail String
t String
o =
    forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"When parsing %s expected a String with the tag of a constructor but got %s." String
t String
o

not2ElemArray :: String -> Int -> Parser fail
not2ElemArray :: forall fail. String -> Int -> Parser fail
not2ElemArray String
t Int
i = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"When parsing %s expected an Array of 2 elements but got %i elements" String
t Int
i

conNotFoundFail2ElemArray :: String -> [String] -> String -> Parser fail
conNotFoundFail2ElemArray :: forall fail. String -> [String] -> String -> Parser fail
conNotFoundFail2ElemArray String
t [String]
cs String
o =
    forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"When parsing %s expected a 2-element Array with a tag and contents element where the tag is one of [%s], but got %s."
                  String
t (forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
cs) String
o

conNotFoundFailObjectSingleField :: String -> [String] -> String -> Parser fail
conNotFoundFailObjectSingleField :: forall fail. String -> [String] -> String -> Parser fail
conNotFoundFailObjectSingleField String
t [String]
cs String
o =
    forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"When parsing %s expected an Object with a single tag/contents pair where the tag is one of [%s], but got %s."
                  String
t (forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
cs) String
o

conNotFoundFailTaggedObject :: String -> [String] -> String -> Parser fail
conNotFoundFailTaggedObject :: forall fail. String -> [String] -> String -> Parser fail
conNotFoundFailTaggedObject String
t [String]
cs String
o =
    forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"When parsing %s expected an Object with a tag field where the value is one of [%s], but got %s."
                  String
t (forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
cs) String
o

parseTypeMismatch' :: String -> String -> String -> String -> Parser fail
parseTypeMismatch' :: forall fail. String -> String -> String -> String -> Parser fail
parseTypeMismatch' String
conName String
tName String
expected String
actual =
    forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"When parsing the constructor %s of type %s expected %s but got %s."
                  String
conName String
tName String
expected String
actual

--------------------------------------------------------------------------------
-- Shared ToJSON and FromJSON code
--------------------------------------------------------------------------------

-- | Functionality common to 'deriveJSON', 'deriveJSON1', and 'deriveJSON2'.
deriveJSONBoth :: (Options -> Name -> Q [Dec])
               -- ^ Function which derives a flavor of 'ToJSON'.
               -> (Options -> Name -> Q [Dec])
               -- ^ Function which derives a flavor of 'FromJSON'.
               -> Options
               -- ^ Encoding options.
               -> Name
               -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON'
               -- instances.
               -> Q [Dec]
deriveJSONBoth :: (Options -> Name -> Q [Dec])
-> (Options -> Name -> Q [Dec]) -> Options -> Name -> Q [Dec]
deriveJSONBoth Options -> Name -> Q [Dec]
dtj Options -> Name -> Q [Dec]
dfj Options
opts Name
name =
    forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a. [a] -> [a] -> [a]
(++) (Options -> Name -> Q [Dec]
dtj Options
opts Name
name) (Options -> Name -> Q [Dec]
dfj Options
opts Name
name)

-- | Functionality common to @deriveToJSON(1)(2)@ and @deriveFromJSON(1)(2)@.
deriveJSONClass :: [(JSONFun, JSONClass -> Name -> Options -> [Type]
                                        -> [ConstructorInfo] -> Q Exp)]
                -- ^ The class methods and the functions which derive them.
                -> JSONClass
                -- ^ The class for which to generate an instance.
                -> Options
                -- ^ Encoding options.
                -> Name
                -- ^ Name of the type for which to generate a class instance
                -- declaration.
                -> Q [Dec]
deriveJSONClass :: [(JSONFun,
  JSONClass
  -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)]
-> JSONClass -> Options -> Name -> Q [Dec]
deriveJSONClass [(JSONFun,
  JSONClass
  -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)]
consFuns JSONClass
jc Options
opts Name
name = do
  DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
  case DatatypeInfo
info of
    DatatypeInfo { datatypeContext :: DatatypeInfo -> [Type]
datatypeContext   = [Type]
ctxt
                 , datatypeName :: DatatypeInfo -> Name
datatypeName      = Name
parentName
#if MIN_VERSION_th_abstraction(0,3,0)
                 , datatypeInstTypes :: DatatypeInfo -> [Type]
datatypeInstTypes = [Type]
instTys
#else
                 , datatypeVars      = instTys
#endif
                 , datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant   = DatatypeVariant
variant
                 , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons      = [ConstructorInfo]
cons
                 } -> do
      ([Type]
instanceCxt, Type
instanceType)
        <- Name
-> JSONClass
-> [Type]
-> [Type]
-> DatatypeVariant
-> Q ([Type], Type)
buildTypeInstance Name
parentName JSONClass
jc [Type]
ctxt [Type]
instTys DatatypeVariant
variant
      (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
instanceCxt)
                          (forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceType)
                          (Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
methodDecs Name
parentName [Type]
instTys [ConstructorInfo]
cons)
  where
    methodDecs :: Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
    methodDecs :: Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
methodDecs Name
parentName [Type]
instTys [ConstructorInfo]
cons = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [(JSONFun,
  JSONClass
  -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)]
consFuns forall a b. (a -> b) -> a -> b
$ \(JSONFun
jf, JSONClass
-> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
jfMaker) ->
      forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (JSONFun -> Arity -> Name
jsonFunValName JSONFun
jf (JSONClass -> Arity
arity JSONClass
jc))
           [ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause []
                    (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ JSONClass
-> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
jfMaker JSONClass
jc Name
parentName Options
opts [Type]
instTys [ConstructorInfo]
cons)
                    []
           ]

mkFunCommon :: (JSONClass -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
            -- ^ The function which derives the expression.
            -> JSONClass
            -- ^ Which class's method is being derived.
            -> Options
            -- ^ Encoding options.
            -> Name
            -- ^ Name of the encoded type.
            -> Q Exp
mkFunCommon :: (JSONClass
 -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
-> JSONClass -> Options -> Name -> Q Exp
mkFunCommon JSONClass
-> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
consFun JSONClass
jc Options
opts Name
name = do
  DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
  case DatatypeInfo
info of
    DatatypeInfo { datatypeContext :: DatatypeInfo -> [Type]
datatypeContext   = [Type]
ctxt
                 , datatypeName :: DatatypeInfo -> Name
datatypeName      = Name
parentName
#if MIN_VERSION_th_abstraction(0,3,0)
                 , datatypeInstTypes :: DatatypeInfo -> [Type]
datatypeInstTypes = [Type]
instTys
#else
                 , datatypeVars      = instTys
#endif
                 , datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant   = DatatypeVariant
variant
                 , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons      = [ConstructorInfo]
cons
                 } -> do
      -- We force buildTypeInstance here since it performs some checks for whether
      -- or not the provided datatype's kind matches the derived method's
      -- typeclass, and produces errors if it can't.
      !([Type], Type)
_ <- Name
-> JSONClass
-> [Type]
-> [Type]
-> DatatypeVariant
-> Q ([Type], Type)
buildTypeInstance Name
parentName JSONClass
jc [Type]
ctxt [Type]
instTys DatatypeVariant
variant
      JSONClass
-> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
consFun JSONClass
jc Name
parentName Options
opts [Type]
instTys [ConstructorInfo]
cons

dispatchFunByType :: JSONClass
                  -> JSONFun
                  -> Name
                  -> TyVarMap
                  -> Bool -- True if we are using the function argument that works
                          -- on lists (e.g., [a] -> Value). False is we are using
                          -- the function argument that works on single values
                          -- (e.g., a -> Value).
                  -> Type
                  -> Q Exp
dispatchFunByType :: JSONClass
-> JSONFun
-> Name
-> Map Name (Name, Name)
-> Bool
-> Type
-> Q Exp
dispatchFunByType JSONClass
_ JSONFun
jf Name
_ Map Name (Name, Name)
tvMap Bool
list (VarT Name
tyName) =
    forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
tyName Map Name (Name, Name)
tvMap of
                Just (Name
tfjExp, Name
tfjlExp) -> if Bool
list then Name
tfjlExp else Name
tfjExp
                Maybe (Name, Name)
Nothing                -> Bool -> JSONFun -> Arity -> Name
jsonFunValOrListName Bool
list JSONFun
jf Arity
Arity0
dispatchFunByType JSONClass
jc JSONFun
jf Name
conName Map Name (Name, Name)
tvMap Bool
list (SigT Type
ty Type
_) =
    JSONClass
-> JSONFun
-> Name
-> Map Name (Name, Name)
-> Bool
-> Type
-> Q Exp
dispatchFunByType JSONClass
jc JSONFun
jf Name
conName Map Name (Name, Name)
tvMap Bool
list Type
ty
dispatchFunByType JSONClass
jc JSONFun
jf Name
conName Map Name (Name, Name)
tvMap Bool
list (ForallT [TyVarBndr Specificity]
_ [Type]
_ Type
ty) =
    JSONClass
-> JSONFun
-> Name
-> Map Name (Name, Name)
-> Bool
-> Type
-> Q Exp
dispatchFunByType JSONClass
jc JSONFun
jf Name
conName Map Name (Name, Name)
tvMap Bool
list Type
ty
dispatchFunByType JSONClass
jc JSONFun
jf Name
conName Map Name (Name, Name)
tvMap Bool
list Type
ty = do
    let tyCon :: Type
        tyArgs :: [Type]
        Type
tyCon :| [Type]
tyArgs = Type -> NonEmpty Type
unapplyTy Type
ty

        numLastArgs :: Int
        numLastArgs :: Int
numLastArgs = forall a. Ord a => a -> a -> a
min (JSONClass -> Int
arityInt JSONClass
jc) (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyArgs)

        lhsArgs, rhsArgs :: [Type]
        ([Type]
lhsArgs, [Type]
rhsArgs) = forall a. Int -> [a] -> ([a], [a])
splitAt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyArgs forall a. Num a => a -> a -> a
- Int
numLastArgs) [Type]
tyArgs

        tyVarNames :: [Name]
        tyVarNames :: [Name]
tyVarNames = forall k a. Map k a -> [k]
M.keys Map Name (Name, Name)
tvMap

    Bool
itf <- [Name] -> Type -> [Type] -> Q Bool
isInTypeFamilyApp [Name]
tyVarNames Type
tyCon [Type]
tyArgs
    if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) [Type]
lhsArgs Bool -> Bool -> Bool
|| Bool
itf
       then forall a. JSONClass -> Name -> a
outOfPlaceTyVarError JSONClass
jc Name
conName
       else if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) [Type]
rhsArgs
            then forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE (Bool -> JSONFun -> Arity -> Name
jsonFunValOrListName Bool
list JSONFun
jf forall a b. (a -> b) -> a -> b
$ forall a. Enum a => Int -> a
toEnum Int
numLastArgs)
                         forall a. a -> [a] -> [a]
: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (JSONClass
-> JSONFun
-> Name
-> Map Name (Name, Name)
-> Bool
-> Type
-> Q Exp
dispatchFunByType JSONClass
jc JSONFun
jf Name
conName Map Name (Name, Name)
tvMap)
                                   (forall a. [a] -> [a]
cycle [Bool
False,Bool
True])
                                   (forall a. [a] -> [a] -> [a]
interleave [Type]
rhsArgs [Type]
rhsArgs)
            else forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ Bool -> JSONFun -> Arity -> Name
jsonFunValOrListName Bool
list JSONFun
jf Arity
Arity0

dispatchToJSON
  :: ToJSONFun -> JSONClass -> Name -> TyVarMap -> Type -> Q Exp
dispatchToJSON :: ToJSONFun
-> JSONClass -> Name -> Map Name (Name, Name) -> Type -> Q Exp
dispatchToJSON ToJSONFun
target JSONClass
jc Name
n Map Name (Name, Name)
tvMap =
    JSONClass
-> JSONFun
-> Name
-> Map Name (Name, Name)
-> Bool
-> Type
-> Q Exp
dispatchFunByType JSONClass
jc (ToJSONFun -> JSONFun
targetToJSONFun ToJSONFun
target) Name
n Map Name (Name, Name)
tvMap Bool
False

dispatchParseJSON
  :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
dispatchParseJSON :: JSONClass -> Name -> Map Name (Name, Name) -> Type -> Q Exp
dispatchParseJSON  JSONClass
jc Name
n Map Name (Name, Name)
tvMap = JSONClass
-> JSONFun
-> Name
-> Map Name (Name, Name)
-> Bool
-> Type
-> Q Exp
dispatchFunByType JSONClass
jc JSONFun
ParseJSON  Name
n Map Name (Name, Name)
tvMap Bool
False

--------------------------------------------------------------------------------
-- Utility functions
--------------------------------------------------------------------------------

-- For the given Types, generate an instance context and head.
buildTypeInstance :: Name
                  -- ^ The type constructor or data family name
                  -> JSONClass
                  -- ^ The typeclass to derive
                  -> Cxt
                  -- ^ The datatype context
                  -> [Type]
                  -- ^ The types to instantiate the instance with
                  -> DatatypeVariant
                  -- ^ Are we dealing with a data family instance or not
                  -> Q (Cxt, Type)
buildTypeInstance :: Name
-> JSONClass
-> [Type]
-> [Type]
-> DatatypeVariant
-> Q ([Type], Type)
buildTypeInstance Name
tyConName JSONClass
jc [Type]
dataCxt [Type]
varTysOrig DatatypeVariant
variant = do
    -- Make sure to expand through type/kind synonyms! Otherwise, the
    -- eta-reduction check might get tripped up over type variables in a
    -- synonym that are actually dropped.
    -- (See GHC Trac #11416 for a scenario where this actually happened.)
    [Type]
varTysExp <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms [Type]
varTysOrig

    let remainingLength :: Int
        remainingLength :: Int
remainingLength = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
varTysOrig forall a. Num a => a -> a -> a
- JSONClass -> Int
arityInt JSONClass
jc

        droppedTysExp :: [Type]
        droppedTysExp :: [Type]
droppedTysExp = forall a. Int -> [a] -> [a]
drop Int
remainingLength [Type]
varTysExp

        droppedStarKindStati :: [StarKindStatus]
        droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati = forall a b. (a -> b) -> [a] -> [b]
map Type -> StarKindStatus
canRealizeKindStar [Type]
droppedTysExp

    -- Check there are enough types to drop and that all of them are either of
    -- kind * or kind k (for some kind variable k). If not, throw an error.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
remainingLength forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem StarKindStatus
NotKindStar [StarKindStatus]
droppedStarKindStati) forall a b. (a -> b) -> a -> b
$
      forall a. JSONClass -> Name -> Q a
derivingKindError JSONClass
jc Name
tyConName

    let droppedKindVarNames :: [Name]
        droppedKindVarNames :: [Name]
droppedKindVarNames = [StarKindStatus] -> [Name]
catKindVarNames [StarKindStatus]
droppedStarKindStati

        -- Substitute kind * for any dropped kind variables
        varTysExpSubst :: [Type]
        varTysExpSubst :: [Type]
varTysExpSubst = forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar [Name]
droppedKindVarNames) [Type]
varTysExp

        remainingTysExpSubst, droppedTysExpSubst :: [Type]
        ([Type]
remainingTysExpSubst, [Type]
droppedTysExpSubst) =
          forall a. Int -> [a] -> ([a], [a])
splitAt Int
remainingLength [Type]
varTysExpSubst

        -- All of the type variables mentioned in the dropped types
        -- (post-synonym expansion)
        droppedTyVarNames :: [Name]
        droppedTyVarNames :: [Name]
droppedTyVarNames = forall a. TypeSubstitution a => a -> [Name]
freeVariables [Type]
droppedTysExpSubst

    -- If any of the dropped types were polykinded, ensure that they are of kind *
    -- after substituting * for the dropped kind variables. If not, throw an error.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
hasKindStar [Type]
droppedTysExpSubst) forall a b. (a -> b) -> a -> b
$
      forall a. JSONClass -> Name -> Q a
derivingKindError JSONClass
jc Name
tyConName

    let preds    :: [Maybe Pred]
        kvNames  :: [[Name]]
        kvNames' :: [Name]
        -- Derive instance constraints (and any kind variables which are specialized
        -- to * in those constraints)
        ([Maybe Type]
preds, [[Name]]
kvNames) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (JSONClass -> Type -> (Maybe Type, [Name])
deriveConstraint JSONClass
jc) [Type]
remainingTysExpSubst
        kvNames' :: [Name]
kvNames' = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Name]]
kvNames

        -- Substitute the kind variables specialized in the constraints with *
        remainingTysExpSubst' :: [Type]
        remainingTysExpSubst' :: [Type]
remainingTysExpSubst' =
          forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar [Name]
kvNames') [Type]
remainingTysExpSubst

        -- We now substitute all of the specialized-to-* kind variable names with
        -- *, but in the original types, not the synonym-expanded types. The reason
        -- we do this is a superficial one: we want the derived instance to resemble
        -- the datatype written in source code as closely as possible. For example,
        -- for the following data family instance:
        --
        --   data family Fam a
        --   newtype instance Fam String = Fam String
        --
        -- We'd want to generate the instance:
        --
        --   instance C (Fam String)
        --
        -- Not:
        --
        --   instance C (Fam [Char])
        remainingTysOrigSubst :: [Type]
        remainingTysOrigSubst :: [Type]
remainingTysOrigSubst =
          forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar ([Name]
droppedKindVarNames forall a. Eq a => [a] -> [a] -> [a]
`union` [Name]
kvNames'))
            forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
remainingLength [Type]
varTysOrig

        isDataFamily :: Bool
        isDataFamily :: Bool
isDataFamily = case DatatypeVariant
variant of
                         DatatypeVariant
Datatype        -> Bool
False
                         DatatypeVariant
Newtype         -> Bool
False
                         DatatypeVariant
DataInstance    -> Bool
True
                         DatatypeVariant
NewtypeInstance -> Bool
True

        remainingTysOrigSubst' :: [Type]
        -- See Note [Kind signatures in derived instances] for an explanation
        -- of the isDataFamily check.
        remainingTysOrigSubst' :: [Type]
remainingTysOrigSubst' =
          if Bool
isDataFamily
             then [Type]
remainingTysOrigSubst
             else forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
unSigT [Type]
remainingTysOrigSubst

        instanceCxt :: Cxt
        instanceCxt :: [Type]
instanceCxt = forall a. [Maybe a] -> [a]
catMaybes [Maybe Type]
preds

        instanceType :: Type
        instanceType :: Type
instanceType = Type -> Type -> Type
AppT (Name -> Type
ConT forall a b. (a -> b) -> a -> b
$ JSONClass -> Name
jsonClassName JSONClass
jc)
                     forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Type
applyTyCon Name
tyConName [Type]
remainingTysOrigSubst'

    -- If the datatype context mentions any of the dropped type variables,
    -- we can't derive an instance, so throw an error.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`predMentionsName` [Name]
droppedTyVarNames) [Type]
dataCxt) forall a b. (a -> b) -> a -> b
$
      forall a. Name -> Type -> Q a
datatypeContextError Name
tyConName Type
instanceType
    -- Also ensure the dropped types can be safely eta-reduced. Otherwise,
    -- throw an error.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Type] -> [Type] -> Bool
canEtaReduce [Type]
remainingTysExpSubst' [Type]
droppedTysExpSubst) forall a b. (a -> b) -> a -> b
$
      forall a. Type -> Q a
etaReductionError Type
instanceType
    forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
instanceCxt, Type
instanceType)

-- | Attempt to derive a constraint on a Type. If successful, return
-- Just the constraint and any kind variable names constrained to *.
-- Otherwise, return Nothing and the empty list.
--
-- See Note [Type inference in derived instances] for the heuristics used to
-- come up with constraints.
deriveConstraint :: JSONClass -> Type -> (Maybe Pred, [Name])
deriveConstraint :: JSONClass -> Type -> (Maybe Type, [Name])
deriveConstraint JSONClass
jc Type
t
  | Bool -> Bool
not (Type -> Bool
isTyVar Type
t) = (forall a. Maybe a
Nothing, [])
  | Type -> Bool
hasKindStar Type
t   = (forall a. a -> Maybe a
Just (Name -> Name -> Type
applyCon (Arity -> Name
jcConstraint Arity
Arity0) Name
tName), [])
  | Bool
otherwise = case Int -> Type -> Maybe [Name]
hasKindVarChain Int
1 Type
t of
      Just [Name]
ns | Arity
jcArity forall a. Ord a => a -> a -> Bool
>= Arity
Arity1
              -> (forall a. a -> Maybe a
Just (Name -> Name -> Type
applyCon (Arity -> Name
jcConstraint Arity
Arity1) Name
tName), [Name]
ns)
      Maybe [Name]
_ -> case Int -> Type -> Maybe [Name]
hasKindVarChain Int
2 Type
t of
           Just [Name]
ns | Arity
jcArity forall a. Eq a => a -> a -> Bool
== Arity
Arity2
                   -> (forall a. a -> Maybe a
Just (Name -> Name -> Type
applyCon (Arity -> Name
jcConstraint Arity
Arity2) Name
tName), [Name]
ns)
           Maybe [Name]
_ -> (forall a. Maybe a
Nothing, [])
  where
    tName :: Name
    tName :: Name
tName = Type -> Name
varTToName Type
t

    jcArity :: Arity
    jcArity :: Arity
jcArity = JSONClass -> Arity
arity JSONClass
jc

    jcConstraint :: Arity -> Name
    jcConstraint :: Arity -> Name
jcConstraint = JSONClass -> Name
jsonClassName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Direction -> Arity -> JSONClass
JSONClass (JSONClass -> Direction
direction JSONClass
jc)

{-
Note [Kind signatures in derived instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

It is possible to put explicit kind signatures into the derived instances, e.g.,

  instance C a => C (Data (f :: * -> *)) where ...

But it is preferable to avoid this if possible. If we come up with an incorrect
kind signature (which is entirely possible, since Template Haskell doesn't always
have the best track record with reifying kind signatures), then GHC will flat-out
reject the instance, which is quite unfortunate.

Plain old datatypes have the advantage that you can avoid using any kind signatures
at all in their instances. This is because a datatype declaration uses all type
variables, so the types that we use in a derived instance uniquely determine their
kinds. As long as we plug in the right types, the kind inferencer can do the rest
of the work. For this reason, we use unSigT to remove all kind signatures before
splicing in the instance context and head.

Data family instances are trickier, since a data family can have two instances that
are distinguished by kind alone, e.g.,

  data family Fam (a :: k)
  data instance Fam (a :: * -> *)
  data instance Fam (a :: *)

If we dropped the kind signatures for C (Fam a), then GHC will have no way of
knowing which instance we are talking about. To avoid this scenario, we always
include explicit kind signatures in data family instances. There is a chance that
the inferred kind signatures will be incorrect, but if so, we can always fall back
on the mk- functions.

Note [Type inference in derived instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Type inference is can be tricky to get right, and we want to avoid recreating the
entirety of GHC's type inferencer in Template Haskell. For this reason, we will
probably never come up with derived instance contexts that are as accurate as
GHC's. But that doesn't mean we can't do anything! There are a couple of simple
things we can do to make instance contexts that work for 80% of use cases:

1. If one of the last type parameters is polykinded, then its kind will be
   specialized to * in the derived instance. We note what kind variable the type
   parameter had and substitute it with * in the other types as well. For example,
   imagine you had

     data Data (a :: k) (b :: k)

   Then you'd want to derived instance to be:

     instance C (Data (a :: *))

   Not:

     instance C (Data (a :: k))

2. We naïvely come up with instance constraints using the following criteria:

   (i)   If there's a type parameter n of kind *, generate a ToJSON n/FromJSON n
         constraint.
   (ii)  If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind
         variables), then generate a ToJSON1 n/FromJSON1 n constraint, and if
         k1/k2 are kind variables, then substitute k1/k2 with * elsewhere in the
         types. We must consider the case where they are kind variables because
         you might have a scenario like this:

           newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1)
             = Compose (f (g a))

         Which would have a derived ToJSON1 instance of:

           instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (Compose f g) where ...
   (iii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are
         * or kind variables), then generate a ToJSON2 n/FromJSON2 n constraint
         and perform kind substitution as in the other cases.
-}

checkExistentialContext :: JSONClass -> TyVarMap -> Cxt -> Name
                        -> Q a -> Q a
checkExistentialContext :: forall a.
JSONClass -> Map Name (Name, Name) -> [Type] -> Name -> Q a -> Q a
checkExistentialContext JSONClass
jc Map Name (Name, Name)
tvMap [Type]
ctxt Name
conName Q a
q =
  if (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`predMentionsName` forall k a. Map k a -> [k]
M.keys Map Name (Name, Name)
tvMap) [Type]
ctxt
       Bool -> Bool -> Bool
|| forall k a. Map k a -> Int
M.size Map Name (Name, Name)
tvMap forall a. Ord a => a -> a -> Bool
< JSONClass -> Int
arityInt JSONClass
jc)
       Bool -> Bool -> Bool
&& Bool -> Bool
not (JSONClass -> Bool
allowExQuant JSONClass
jc)
     then forall a. Name -> a
existentialContextError Name
conName
     else Q a
q

{-
Note [Matching functions with GADT type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

When deriving ToJSON2, there is a tricky corner case to consider:

  data Both a b where
    BothCon :: x -> x -> Both x x

Which encoding functions should be applied to which arguments of BothCon?
We have a choice, since both the function of type (a -> Value) and of type
(b -> Value) can be applied to either argument. In such a scenario, the
second encoding function takes precedence over the first encoding function, so the
derived ToJSON2 instance would be something like:

  instance ToJSON2 Both where
    liftToJSON2 tj1 tj2 p (BothCon x1 x2) = Array $ create $ do
      mv <- unsafeNew 2
      unsafeWrite mv 0 (tj1 x1)
      unsafeWrite mv 1 (tj2 x2)
      return mv

This is not an arbitrary choice, as this definition ensures that
liftToJSON2 toJSON = liftToJSON for a derived ToJSON1 instance for
Both.
-}

-- A mapping of type variable Names to their encoding/decoding function Names.
-- For example, in a ToJSON2 declaration, a TyVarMap might look like
--
-- { a ~> (tj1, tjl1)
-- , b ~> (tj2, tjl2) }
--
-- where a and b are the last two type variables of the datatype, tj1 and tjl1 are
-- the function arguments of types (a -> Value) and ([a] -> Value), and tj2 and tjl2
-- are the function arguments of types (b -> Value) and ([b] -> Value).
type TyVarMap = Map Name (Name, Name)

-- | Returns True if a Type has kind *.
hasKindStar :: Type -> Bool
hasKindStar :: Type -> Bool
hasKindStar VarT{}         = Bool
True
hasKindStar (SigT Type
_ Type
StarT) = Bool
True
hasKindStar Type
_              = Bool
False

-- Returns True is a kind is equal to *, or if it is a kind variable.
isStarOrVar :: Kind -> Bool
isStarOrVar :: Type -> Bool
isStarOrVar Type
StarT  = Bool
True
isStarOrVar VarT{} = Bool
True
isStarOrVar Type
_      = Bool
False

-- Generate a list of fresh names with a common prefix, and numbered suffixes.
newNameList :: String -> Int -> Q [Name]
newNameList :: String -> Int -> Q [Name]
newNameList String
prefix Int
len = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). Quote m => String -> m Name
newName [String
prefix forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n | Int
n <- [Int
1..Int
len]]

-- | @hasKindVarChain n kind@ Checks if @kind@ is of the form
-- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or
-- kind variables.
hasKindVarChain :: Int -> Type -> Maybe [Name]
hasKindVarChain :: Int -> Type -> Maybe [Name]
hasKindVarChain Int
kindArrows Type
t =
  let uk :: NonEmpty Type
uk = Type -> NonEmpty Type
uncurryKind (Type -> Type
tyKind Type
t)
  in if (forall a. NonEmpty a -> Int
NE.length NonEmpty Type
uk forall a. Num a => a -> a -> a
- Int
1 forall a. Eq a => a -> a -> Bool
== Int
kindArrows) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
F.all Type -> Bool
isStarOrVar NonEmpty Type
uk
        then forall a. a -> Maybe a
Just (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. TypeSubstitution a => a -> [Name]
freeVariables NonEmpty Type
uk)
        else forall a. Maybe a
Nothing

-- | If a Type is a SigT, returns its kind signature. Otherwise, return *.
tyKind :: Type -> Kind
tyKind :: Type -> Type
tyKind (SigT Type
_ Type
k) = Type
k
tyKind Type
_          = Type
starK

-- | Extract Just the Name from a type variable. If the argument Type is not a
-- type variable, return Nothing.
varTToNameMaybe :: Type -> Maybe Name
varTToNameMaybe :: Type -> Maybe Name
varTToNameMaybe (VarT Name
n)   = forall a. a -> Maybe a
Just Name
n
varTToNameMaybe (SigT Type
t Type
_) = Type -> Maybe Name
varTToNameMaybe Type
t
varTToNameMaybe Type
_          = forall a. Maybe a
Nothing

-- | Extract the Name from a type variable. If the argument Type is not a
-- type variable, throw an error.
varTToName :: Type -> Name
varTToName :: Type -> Name
varTToName = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"Not a type variable!") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe Name
varTToNameMaybe

interleave :: [a] -> [a] -> [a]
interleave :: forall a. [a] -> [a] -> [a]
interleave (a
a1:[a]
a1s) (a
a2:[a]
a2s) = a
a1forall a. a -> [a] -> [a]
:a
a2forall a. a -> [a] -> [a]
:forall a. [a] -> [a] -> [a]
interleave [a]
a1s [a]
a2s
interleave [a]
_        [a]
_        = []

-- | Fully applies a type constructor to its type variables.
applyTyCon :: Name -> [Type] -> Type
applyTyCon :: Name -> [Type] -> Type
applyTyCon = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type
ConT

-- | Is the given type a variable?
isTyVar :: Type -> Bool
isTyVar :: Type -> Bool
isTyVar (VarT Name
_)   = Bool
True
isTyVar (SigT Type
t Type
_) = Type -> Bool
isTyVar Type
t
isTyVar Type
_          = Bool
False

-- | Detect if a Name in a list of provided Names occurs as an argument to some
-- type family. This makes an effort to exclude /oversaturated/ arguments to
-- type families. For instance, if one declared the following type family:
--
-- @
-- type family F a :: Type -> Type
-- @
--
-- Then in the type @F a b@, we would consider @a@ to be an argument to @F@,
-- but not @b@.
isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool
isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool
isInTypeFamilyApp [Name]
names Type
tyFun [Type]
tyArgs =
  case Type
tyFun of
    ConT Name
tcName -> Name -> Q Bool
go Name
tcName
    Type
_           -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  where
    go :: Name -> Q Bool
    go :: Name -> Q Bool
go Name
tcName = do
      Info
info <- Name -> Q Info
reify Name
tcName
      case Info
info of
#if MIN_VERSION_template_haskell(2,11,0)
        FamilyI (OpenTypeFamilyD (TypeFamilyHead Name
_ [TyVarBndr ()]
bndrs FamilyResultSig
_ Maybe InjectivityAnn
_)) [Dec]
_
          -> forall a. [a] -> Q Bool
withinFirstArgs [TyVarBndr ()]
bndrs
        FamilyI (ClosedTypeFamilyD (TypeFamilyHead Name
_ [TyVarBndr ()]
bndrs FamilyResultSig
_ Maybe InjectivityAnn
_) [TySynEqn]
_) [Dec]
_
          -> forall a. [a] -> Q Bool
withinFirstArgs [TyVarBndr ()]
bndrs
#else
        FamilyI (FamilyD TypeFam _ bndrs _) _
          -> withinFirstArgs bndrs
        FamilyI (ClosedTypeFamilyD _ bndrs _ _) _
          -> withinFirstArgs bndrs
#endif
        Info
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      where
        withinFirstArgs :: [a] -> Q Bool
        withinFirstArgs :: forall a. [a] -> Q Bool
withinFirstArgs [a]
bndrs =
          let firstArgs :: [Type]
firstArgs = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
bndrs) [Type]
tyArgs
              argFVs :: [Name]
argFVs    = forall a. TypeSubstitution a => a -> [Name]
freeVariables [Type]
firstArgs
          in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
argFVs) [Name]
names

-- | Peel off a kind signature from a Type (if it has one).
unSigT :: Type -> Type
unSigT :: Type -> Type
unSigT (SigT Type
t Type
_) = Type
t
unSigT Type
t          = Type
t

-- | Are all of the items in a list (which have an ordering) distinct?
--
-- This uses Set (as opposed to nub) for better asymptotic time complexity.
allDistinct :: Ord a => [a] -> Bool
allDistinct :: forall a. Ord a => [a] -> Bool
allDistinct = forall a. Ord a => Set a -> [a] -> Bool
allDistinct' forall a. Set a
Set.empty
  where
    allDistinct' :: Ord a => Set a -> [a] -> Bool
    allDistinct' :: forall a. Ord a => Set a -> [a] -> Bool
allDistinct' Set a
uniqs (a
x:[a]
xs)
        | a
x forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
uniqs = Bool
False
        | Bool
otherwise            = forall a. Ord a => Set a -> [a] -> Bool
allDistinct' (forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
uniqs) [a]
xs
    allDistinct' Set a
_ [a]
_           = Bool
True

-- | Does the given type mention any of the Names in the list?
mentionsName :: Type -> [Name] -> Bool
mentionsName :: Type -> [Name] -> Bool
mentionsName = Type -> [Name] -> Bool
go
  where
    go :: Type -> [Name] -> Bool
    go :: Type -> [Name] -> Bool
go (AppT Type
t1 Type
t2) [Name]
names = Type -> [Name] -> Bool
go Type
t1 [Name]
names Bool -> Bool -> Bool
|| Type -> [Name] -> Bool
go Type
t2 [Name]
names
    go (SigT Type
t Type
_k)  [Name]
names = Type -> [Name] -> Bool
go Type
t [Name]
names
                              Bool -> Bool -> Bool
|| Type -> [Name] -> Bool
go Type
_k [Name]
names
    go (VarT Name
n)     [Name]
names = Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
names
    go Type
_            [Name]
_     = Bool
False

-- | Does an instance predicate mention any of the Names in the list?
predMentionsName :: Pred -> [Name] -> Bool
#if MIN_VERSION_template_haskell(2,10,0)
predMentionsName :: Type -> [Name] -> Bool
predMentionsName = Type -> [Name] -> Bool
mentionsName
#else
predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys
predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names
#endif

-- | Split an applied type into its individual components. For example, this:
--
-- @
-- Either Int Char
-- @
--
-- would split to this:
--
-- @
-- [Either, Int, Char]
-- @
unapplyTy :: Type -> NonEmpty Type
unapplyTy :: Type -> NonEmpty Type
unapplyTy = forall a. NonEmpty a -> NonEmpty a
NE.reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> NonEmpty Type
go
  where
    go :: Type -> NonEmpty Type
    go :: Type -> NonEmpty Type
go (AppT Type
t1 Type
t2)    = Type
t2 forall a. a -> NonEmpty a -> NonEmpty a
<| Type -> NonEmpty Type
go Type
t1
    go (SigT Type
t Type
_)      = Type -> NonEmpty Type
go Type
t
    go (ForallT [TyVarBndr Specificity]
_ [Type]
_ Type
t) = Type -> NonEmpty Type
go Type
t
    go Type
t               = Type
t forall a. a -> [a] -> NonEmpty a
:| []

-- | Split a type signature by the arrows on its spine. For example, this:
--
-- @
-- forall a b. (a ~ b) => (a -> b) -> Char -> ()
-- @
--
-- would split to this:
--
-- @
-- (a ~ b, [a -> b, Char, ()])
-- @
uncurryTy :: Type -> (Cxt, NonEmpty Type)
uncurryTy :: Type -> ([Type], NonEmpty Type)
uncurryTy (AppT (AppT Type
ArrowT Type
t1) Type
t2) =
  let ([Type]
ctxt, NonEmpty Type
tys) = Type -> ([Type], NonEmpty Type)
uncurryTy Type
t2
  in ([Type]
ctxt, Type
t1 forall a. a -> NonEmpty a -> NonEmpty a
<| NonEmpty Type
tys)
uncurryTy (SigT Type
t Type
_) = Type -> ([Type], NonEmpty Type)
uncurryTy Type
t
uncurryTy (ForallT [TyVarBndr Specificity]
_ [Type]
ctxt Type
t) =
  let ([Type]
ctxt', NonEmpty Type
tys) = Type -> ([Type], NonEmpty Type)
uncurryTy Type
t
  in ([Type]
ctxt forall a. [a] -> [a] -> [a]
++ [Type]
ctxt', NonEmpty Type
tys)
uncurryTy Type
t = ([], Type
t forall a. a -> [a] -> NonEmpty a
:| [])

-- | Like uncurryType, except on a kind level.
uncurryKind :: Kind -> NonEmpty Kind
uncurryKind :: Type -> NonEmpty Type
uncurryKind = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([Type], NonEmpty Type)
uncurryTy

createKindChain :: Int -> Kind
createKindChain :: Int -> Type
createKindChain = Type -> Int -> Type
go Type
starK
  where
    go :: Kind -> Int -> Kind
    go :: Type -> Int -> Type
go Type
k Int
0 = Type
k
    go Type
k !Int
n = Type -> Int -> Type
go (Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
ArrowT Type
StarT) Type
k) (Int
n forall a. Num a => a -> a -> a
- Int
1)

-- | Makes a string literal expression from a constructor's name.
conNameExp :: Options -> ConstructorInfo -> Q Exp
conNameExp :: Options -> ConstructorInfo -> Q Exp
conNameExp Options
opts = forall (m :: * -> *). Quote m => Lit -> m Exp
litE
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
stringL
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> String -> String
constructorTagModifier Options
opts
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorInfo -> Name
constructorName

-- | Extracts a record field label.
fieldLabel :: Options -- ^ Encoding options
           -> Name
           -> String
fieldLabel :: Options -> Name -> String
fieldLabel Options
opts = Options -> String -> String
fieldLabelModifier Options
opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase

-- | The name of the outermost 'Value' constructor.
valueConName :: Value -> String
valueConName :: Value -> String
valueConName (Object Object
_) = String
"Object"
valueConName (Array  Array
_) = String
"Array"
valueConName (String Text
_) = String
"String"
valueConName (Number Scientific
_) = String
"Number"
valueConName (Bool   Bool
_) = String
"Boolean"
valueConName Value
Null       = String
"Null"

applyCon :: Name -> Name -> Pred
applyCon :: Name -> Name -> Type
applyCon Name
con Name
t =
#if MIN_VERSION_template_haskell(2,10,0)
          Type -> Type -> Type
AppT (Name -> Type
ConT Name
con) (Name -> Type
VarT Name
t)
#else
          ClassP con [VarT t]
#endif

-- | Checks to see if the last types in a data family instance can be safely eta-
-- reduced (i.e., dropped), given the other types. This checks for three conditions:
--
-- (1) All of the dropped types are type variables
-- (2) All of the dropped types are distinct
-- (3) None of the remaining types mention any of the dropped types
canEtaReduce :: [Type] -> [Type] -> Bool
canEtaReduce :: [Type] -> [Type] -> Bool
canEtaReduce [Type]
remaining [Type]
dropped =
       forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isTyVar [Type]
dropped
    Bool -> Bool -> Bool
&& forall a. Ord a => [a] -> Bool
allDistinct [Name]
droppedNames -- Make sure not to pass something of type [Type], since Type
                                -- didn't have an Ord instance until template-haskell-2.10.0.0
    Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
droppedNames) [Type]
remaining)
  where
    droppedNames :: [Name]
    droppedNames :: [Name]
droppedNames = forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName [Type]
dropped

-------------------------------------------------------------------------------
-- Expanding type synonyms
-------------------------------------------------------------------------------

applySubstitutionKind :: Map Name Kind -> Type -> Type
applySubstitutionKind :: Map Name Type -> Type -> Type
applySubstitutionKind = forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution

substNameWithKind :: Name -> Kind -> Type -> Type
substNameWithKind :: Name -> Type -> Type -> Type
substNameWithKind Name
n Type
k = Map Name Type -> Type -> Type
applySubstitutionKind (forall k a. k -> a -> Map k a
M.singleton Name
n Type
k)

substNamesWithKindStar :: [Name] -> Type -> Type
substNamesWithKindStar :: [Name] -> Type -> Type
substNamesWithKindStar [Name]
ns Type
t = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' (Name -> Type -> Type -> Type
`substNameWithKind` Type
starK) Type
t [Name]
ns

-------------------------------------------------------------------------------
-- Error messages
-------------------------------------------------------------------------------

-- | Either the given data type doesn't have enough type variables, or one of
-- the type variables to be eta-reduced cannot realize kind *.
derivingKindError :: JSONClass -> Name -> Q a
derivingKindError :: forall a. JSONClass -> Name -> Q a
derivingKindError JSONClass
jc Name
tyConName = forall (m :: * -> *) a. MonadFail m => String -> m a
fail
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"Cannot derive well-kinded instance of form ‘"
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
className
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' '
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> (String -> String) -> String -> String
showParen Bool
True
    ( String -> String -> String
showString (Name -> String
nameBase Name
tyConName)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
" ..."
    )
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"‘\n\tClass "
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
className
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
" expects an argument of kind "
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString (forall a. Ppr a => a -> String
pprint forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type
createKindChain forall a b. (a -> b) -> a -> b
$ JSONClass -> Int
arityInt JSONClass
jc)
  forall a b. (a -> b) -> a -> b
$ String
""
  where
    className :: String
    className :: String
className = Name -> String
nameBase forall a b. (a -> b) -> a -> b
$ JSONClass -> Name
jsonClassName JSONClass
jc

-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce
-- function for the criteria it would have to meet).
etaReductionError :: Type -> Q a
etaReductionError :: forall a. Type -> Q a
etaReductionError Type
instanceType = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
    String
"Cannot eta-reduce to an instance of form \n\tinstance (...) => "
    forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Type
instanceType

-- | The data type has a DatatypeContext which mentions one of the eta-reduced
-- type variables.
datatypeContextError :: Name -> Type -> Q a
datatypeContextError :: forall a. Name -> Type -> Q a
datatypeContextError Name
dataName Type
instanceType = forall (m :: * -> *) a. MonadFail m => String -> m a
fail
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"Can't make a derived instance of ‘"
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString (forall a. Ppr a => a -> String
pprint Type
instanceType)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"‘:\n\tData type ‘"
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString (Name -> String
nameBase Name
dataName)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"‘ must not have a class context involving the last type argument(s)"
    forall a b. (a -> b) -> a -> b
$ String
""

-- | The data type mentions one of the n eta-reduced type variables in a place other
-- than the last nth positions of a data type in a constructor's field.
outOfPlaceTyVarError :: JSONClass -> Name -> a
outOfPlaceTyVarError :: forall a. JSONClass -> Name -> a
outOfPlaceTyVarError JSONClass
jc Name
conName = forall a. HasCallStack => String -> a
error
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"Constructor ‘"
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString (Name -> String
nameBase Name
conName)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"‘ must only use its last "
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String -> String
shows Int
n
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
" type variable(s) within the last "
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String -> String
shows Int
n
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
" argument(s) of a data type"
    forall a b. (a -> b) -> a -> b
$ String
""
  where
    n :: Int
    n :: Int
n = JSONClass -> Int
arityInt JSONClass
jc

-- | The data type has an existential constraint which mentions one of the
-- eta-reduced type variables.
existentialContextError :: Name -> a
existentialContextError :: forall a. Name -> a
existentialContextError Name
conName = forall a. HasCallStack => String -> a
error
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"Constructor ‘"
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString (Name -> String
nameBase Name
conName)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"‘ must be truly polymorphic in the last argument(s) of the data type"
  forall a b. (a -> b) -> a -> b
$ String
""

-------------------------------------------------------------------------------
-- Class-specific constants
-------------------------------------------------------------------------------

-- | A representation of the arity of the ToJSON/FromJSON typeclass being derived.
data Arity = Arity0 | Arity1 | Arity2
  deriving (Int -> Arity
Arity -> Int
Arity -> [Arity]
Arity -> Arity
Arity -> Arity -> [Arity]
Arity -> Arity -> Arity -> [Arity]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Arity -> Arity -> Arity -> [Arity]
$cenumFromThenTo :: Arity -> Arity -> Arity -> [Arity]
enumFromTo :: Arity -> Arity -> [Arity]
$cenumFromTo :: Arity -> Arity -> [Arity]
enumFromThen :: Arity -> Arity -> [Arity]
$cenumFromThen :: Arity -> Arity -> [Arity]
enumFrom :: Arity -> [Arity]
$cenumFrom :: Arity -> [Arity]
fromEnum :: Arity -> Int
$cfromEnum :: Arity -> Int
toEnum :: Int -> Arity
$ctoEnum :: Int -> Arity
pred :: Arity -> Arity
$cpred :: Arity -> Arity
succ :: Arity -> Arity
$csucc :: Arity -> Arity
Enum, Arity -> Arity -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Arity -> Arity -> Bool
$c/= :: Arity -> Arity -> Bool
== :: Arity -> Arity -> Bool
$c== :: Arity -> Arity -> Bool
Eq, Eq Arity
Arity -> Arity -> Bool
Arity -> Arity -> Ordering
Arity -> Arity -> Arity
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Arity -> Arity -> Arity
$cmin :: Arity -> Arity -> Arity
max :: Arity -> Arity -> Arity
$cmax :: Arity -> Arity -> Arity
>= :: Arity -> Arity -> Bool
$c>= :: Arity -> Arity -> Bool
> :: Arity -> Arity -> Bool
$c> :: Arity -> Arity -> Bool
<= :: Arity -> Arity -> Bool
$c<= :: Arity -> Arity -> Bool
< :: Arity -> Arity -> Bool
$c< :: Arity -> Arity -> Bool
compare :: Arity -> Arity -> Ordering
$ccompare :: Arity -> Arity -> Ordering
Ord)

-- | Whether ToJSON(1)(2) or FromJSON(1)(2) is being derived.
data Direction = To | From

-- | A representation of which typeclass method is being spliced in.
data JSONFun = ToJSON | ToEncoding | ParseJSON

-- | A refinement of JSONFun to [ToJSON, ToEncoding].
data ToJSONFun = Value | Encoding

targetToJSONFun :: ToJSONFun -> JSONFun
targetToJSONFun :: ToJSONFun -> JSONFun
targetToJSONFun ToJSONFun
Value = JSONFun
ToJSON
targetToJSONFun ToJSONFun
Encoding = JSONFun
ToEncoding

-- | A representation of which typeclass is being derived.
data JSONClass = JSONClass { JSONClass -> Direction
direction :: Direction, JSONClass -> Arity
arity :: Arity }

toJSONClass, toJSON1Class, toJSON2Class,
    fromJSONClass, fromJSON1Class, fromJSON2Class :: JSONClass
toJSONClass :: JSONClass
toJSONClass    = Direction -> Arity -> JSONClass
JSONClass Direction
To   Arity
Arity0
toJSON1Class :: JSONClass
toJSON1Class   = Direction -> Arity -> JSONClass
JSONClass Direction
To   Arity
Arity1
toJSON2Class :: JSONClass
toJSON2Class   = Direction -> Arity -> JSONClass
JSONClass Direction
To   Arity
Arity2
fromJSONClass :: JSONClass
fromJSONClass  = Direction -> Arity -> JSONClass
JSONClass Direction
From Arity
Arity0
fromJSON1Class :: JSONClass
fromJSON1Class = Direction -> Arity -> JSONClass
JSONClass Direction
From Arity
Arity1
fromJSON2Class :: JSONClass
fromJSON2Class = Direction -> Arity -> JSONClass
JSONClass Direction
From Arity
Arity2

jsonClassName :: JSONClass -> Name
jsonClassName :: JSONClass -> Name
jsonClassName (JSONClass Direction
To   Arity
Arity0) = ''ToJSON
jsonClassName (JSONClass Direction
To   Arity
Arity1) = ''ToJSON1
jsonClassName (JSONClass Direction
To   Arity
Arity2) = ''ToJSON2
jsonClassName (JSONClass Direction
From Arity
Arity0) = ''FromJSON
jsonClassName (JSONClass Direction
From Arity
Arity1) = ''FromJSON1
jsonClassName (JSONClass Direction
From Arity
Arity2) = ''FromJSON2

jsonFunValName :: JSONFun -> Arity -> Name
jsonFunValName :: JSONFun -> Arity -> Name
jsonFunValName JSONFun
ToJSON     Arity
Arity0 = 'toJSON
jsonFunValName JSONFun
ToJSON     Arity
Arity1 = 'liftToJSON
jsonFunValName JSONFun
ToJSON     Arity
Arity2 = 'liftToJSON2
jsonFunValName JSONFun
ToEncoding Arity
Arity0 = 'toEncoding
jsonFunValName JSONFun
ToEncoding Arity
Arity1 = 'liftToEncoding
jsonFunValName JSONFun
ToEncoding Arity
Arity2 = 'liftToEncoding2
jsonFunValName JSONFun
ParseJSON  Arity
Arity0 = 'parseJSON
jsonFunValName JSONFun
ParseJSON  Arity
Arity1 = 'liftParseJSON
jsonFunValName JSONFun
ParseJSON  Arity
Arity2 = 'liftParseJSON2

jsonFunListName :: JSONFun -> Arity -> Name
jsonFunListName :: JSONFun -> Arity -> Name
jsonFunListName JSONFun
ToJSON     Arity
Arity0 = 'toJSONList
jsonFunListName JSONFun
ToJSON     Arity
Arity1 = 'liftToJSONList
jsonFunListName JSONFun
ToJSON     Arity
Arity2 = 'liftToJSONList2
jsonFunListName JSONFun
ToEncoding Arity
Arity0 = 'toEncodingList
jsonFunListName JSONFun
ToEncoding Arity
Arity1 = 'liftToEncodingList
jsonFunListName JSONFun
ToEncoding Arity
Arity2 = 'liftToEncodingList2
jsonFunListName JSONFun
ParseJSON  Arity
Arity0 = 'parseJSONList
jsonFunListName JSONFun
ParseJSON  Arity
Arity1 = 'liftParseJSONList
jsonFunListName JSONFun
ParseJSON  Arity
Arity2 = 'liftParseJSONList2

jsonFunValOrListName :: Bool -- e.g., toJSONList if True, toJSON if False
                     -> JSONFun -> Arity -> Name
jsonFunValOrListName :: Bool -> JSONFun -> Arity -> Name
jsonFunValOrListName Bool
False = JSONFun -> Arity -> Name
jsonFunValName
jsonFunValOrListName Bool
True  = JSONFun -> Arity -> Name
jsonFunListName

arityInt :: JSONClass -> Int
arityInt :: JSONClass -> Int
arityInt = forall a. Enum a => a -> Int
fromEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONClass -> Arity
arity

allowExQuant :: JSONClass -> Bool
allowExQuant :: JSONClass -> Bool
allowExQuant (JSONClass Direction
To Arity
_) = Bool
True
allowExQuant JSONClass
_                = Bool
False

-------------------------------------------------------------------------------
-- StarKindStatus
-------------------------------------------------------------------------------

-- | Whether a type is not of kind *, is of kind *, or is a kind variable.
data StarKindStatus = NotKindStar
                    | KindStar
                    | IsKindVar Name
  deriving StarKindStatus -> StarKindStatus -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StarKindStatus -> StarKindStatus -> Bool
$c/= :: StarKindStatus -> StarKindStatus -> Bool
== :: StarKindStatus -> StarKindStatus -> Bool
$c== :: StarKindStatus -> StarKindStatus -> Bool
Eq

-- | Does a Type have kind * or k (for some kind variable k)?
canRealizeKindStar :: Type -> StarKindStatus
canRealizeKindStar :: Type -> StarKindStatus
canRealizeKindStar Type
t = case Type
t of
    Type
_ | Type -> Bool
hasKindStar Type
t -> StarKindStatus
KindStar
    SigT Type
_ (VarT Name
k) -> Name -> StarKindStatus
IsKindVar Name
k
    Type
_ -> StarKindStatus
NotKindStar

-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.
-- Otherwise, returns 'Nothing'.
starKindStatusToName :: StarKindStatus -> Maybe Name
starKindStatusToName :: StarKindStatus -> Maybe Name
starKindStatusToName (IsKindVar Name
n) = forall a. a -> Maybe a
Just Name
n
starKindStatusToName StarKindStatus
_             = forall a. Maybe a
Nothing

-- | Concat together all of the StarKindStatuses that are IsKindVar and extract
-- the kind variables' Names out.
catKindVarNames :: [StarKindStatus] -> [Name]
catKindVarNames :: [StarKindStatus] -> [Name]
catKindVarNames = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe StarKindStatus -> Maybe Name
starKindStatusToName