{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# 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' ''(,,,))
@

-}
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]
_ [] = [Char] -> Q Exp
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Data.Aeson.TH.consToValue: "
                             [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Not a single constructor given!"

consToValue ToJSONFun
target JSONClass
jc Options
opts [Type]
instTys [ConstructorInfo]
cons = (ShortByteString -> Q Exp)
-> ((ShortByteString -> Q Exp) -> Q Exp) -> Q Exp
forall a. Ord a => (a -> Q Exp) -> ((a -> Q Exp) -> Q Exp) -> Q Exp
autoletE ShortByteString -> Q Exp
liftSBS (((ShortByteString -> Q Exp) -> Q Exp) -> Q Exp)
-> ((ShortByteString -> Q Exp) -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \ShortByteString -> Q Exp
letInsert -> do
    Name
value <- [Char] -> Q Name
newName [Char]
"value"
    [Name]
tjs   <- [Char] -> Int -> Q [Name]
newNameList [Char]
"_tj"  (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ JSONClass -> Int
arityInt JSONClass
jc
    [Name]
tjls  <- [Char] -> Int -> Q [Name]
newNameList [Char]
"_tjl" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ JSONClass -> Int
arityInt JSONClass
jc
    let zippedTJs :: [(Name, Name)]
zippedTJs      = [Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
tjs [Name]
tjls
        interleavedTJs :: [Name]
interleavedTJs = [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
interleave [Name]
tjs [Name]
tjls
        lastTyVars :: [Name]
lastTyVars     = (Type -> Name) -> [Type] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName ([Type] -> [Name]) -> [Type] -> [Name]
forall a b. (a -> b) -> a -> b
$ Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
drop ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
instTys Int -> Int -> Int
forall a. Num a => a -> a -> a
- JSONClass -> Int
arityInt JSONClass
jc) [Type]
instTys
        tvMap :: Map Name (Name, Name)
tvMap          = [(Name, (Name, Name))] -> Map Name (Name, Name)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, (Name, Name))] -> Map Name (Name, Name))
-> [(Name, (Name, Name))] -> Map Name (Name, Name)
forall a b. (a -> b) -> a -> b
$ [Name] -> [(Name, Name)] -> [(Name, (Name, Name))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
lastTyVars [(Name, Name)]
zippedTJs
    [PatQ] -> Q Exp -> Q Exp
lamE ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP ([Name] -> [PatQ]) -> [Name] -> [PatQ]
forall a b. (a -> b) -> a -> b
$ [Name]
interleavedTJs [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name
value]) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
        Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
value) ((ShortByteString -> Q Exp) -> Map Name (Name, Name) -> [MatchQ]
matches ShortByteString -> Q Exp
letInsert Map Name (Name, Name)
tvMap)
  where
    matches :: (ShortByteString -> Q Exp) -> Map Name (Name, Name) -> [MatchQ]
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
-> MatchQ
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
&& (ConstructorInfo -> Bool) -> [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ConstructorInfo -> Bool
isNullary [ConstructorInfo]
cons ->
              [ PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
conName []) (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
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
-> MatchQ
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 = Q Exp -> Q Exp -> Q Exp
appE [|String|] (Q Exp -> Q Exp) -> (Name -> Q Exp) -> Name -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> Name -> Q Exp
conTxt Options
opts
conStr ToJSONFun
Encoding Options
opts = Q Exp -> Q Exp -> Q Exp
appE [|E.text|] (Q Exp -> Q Exp) -> (Name -> Q Exp) -> Name -> Q Exp
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 = Q Exp -> Q Exp -> Q Exp
appE [|T.pack|] (Q Exp -> Q Exp) -> (Name -> Q Exp) -> Name -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Q Exp
stringE ([Char] -> Q Exp) -> (Name -> [Char]) -> Name -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> Name -> [Char]
conString Options
opts

-- | Name of the constructor.
conString :: Options -> Name -> String
conString :: Options -> Name -> [Char]
conString Options
opts = Options -> [Char] -> [Char]
constructorTagModifier Options
opts ([Char] -> [Char]) -> (Name -> [Char]) -> Name -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
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 } = [Type] -> Bool
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
-> ([Char] -> Q Exp)
-> Q Exp
sumToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target Options
opts Bool
multiCons Bool
nullary Name
conName
    Q Exp
value
    [Char] -> Q Exp
pairs
  where
    pairs :: [Char] -> Q Exp
pairs [Char]
contentsFieldName = (ShortByteString -> Q Exp) -> ToJSONFun -> [Char] -> Q Exp -> Q Exp
pairE ShortByteString -> Q Exp
letInsert ToJSONFun
target [Char]
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
-> ([Char] -> 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)
    (Q Exp -> [Char] -> Q Exp
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
-> ([Char] -> Q Exp)
-> Q Exp
sumToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target Options
opts Bool
multiCons Bool
nullary Name
conName Q Exp
value [Char] -> 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{[Char]
tagFieldName :: SumEncoding -> [Char]
tagFieldName :: [Char]
tagFieldName, [Char]
contentsFieldName :: SumEncoding -> [Char]
contentsFieldName :: [Char]
contentsFieldName} ->
            -- TODO: Maybe throw an error in case
            -- tagFieldName overwrites a field in pairs.
            let tag :: Q Exp
tag = (ShortByteString -> Q Exp) -> ToJSONFun -> [Char] -> Q Exp -> Q Exp
pairE ShortByteString -> Q Exp
letInsert ToJSONFun
target [Char]
tagFieldName (ToJSONFun -> Options -> Name -> Q Exp
conStr ToJSONFun
target Options
opts Name
conName)
                content :: Q Exp
content = [Char] -> Q Exp
pairs [Char]
contentsFieldName
            in ToJSONFun -> Q Exp -> Q Exp
fromPairsE ToJSONFun
target (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
              if Bool
nullary then Q Exp
tag else Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp Q Exp
tag [|(Monoid.<>)|] Q Exp
content
          SumEncoding
ObjectWithSingleField ->
            (ShortByteString -> Q Exp)
-> ToJSONFun -> [([Char], Q Exp)] -> Q Exp
objectE ShortByteString -> Q Exp
letInsert ToJSONFun
target [(Options -> Name -> [Char]
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
-> MatchQ
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' <- (Type -> Q Type) -> [Type] -> Q [Type]
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 = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
argTys'
    [Name]
args <- [Char] -> Int -> Q [Name]
newNameList [Char]
"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
                      Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
arg
                  | (Name
arg, Type
argTy) <- [Name] -> [Type] -> [(Name, Type)]
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

    PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
conName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
args)
          (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
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 ([Type] -> Bool
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
-> MatchQ
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' <- (Type -> Q Type) -> [Type] -> Q [Type]
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 <- [Char] -> Int -> Q [Name]
newNameList [Char]
"arg" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
argTys'
        let pairs :: Q Exp
pairs | Options -> Bool
omitNothingFields Options
opts = Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp Q Exp
maybeFields
                                                      [|(Monoid.<>)|]
                                                      Q Exp
restFields
                  | Bool
otherwise = [Q Exp] -> Q Exp
mconcatE (((Q Exp, Type, Name) -> Q Exp) -> [(Q Exp, Type, Name)] -> [Q Exp]
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 = [Q Exp] -> [Type] -> [Name] -> [(Q Exp, Type, Name)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 ((Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
args) [Type]
argTys' [Name]
fields

            maybeFields :: Q Exp
maybeFields = [Q Exp] -> Q Exp
mconcatE (((Q Exp, Type, Name) -> Q Exp) -> [(Q Exp, Type, Name)] -> [Q Exp]
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 (((Q Exp, Type, Name) -> Q Exp) -> [(Q Exp, Type, Name)] -> [Q Exp]
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) = ((Q Exp, Type, Name) -> Bool)
-> [(Q Exp, Type, Name)]
-> ([(Q Exp, Type, Name)], [(Q Exp, Type, Name)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Q Exp, Type, Name) -> Bool
forall a b. (a, Type, b) -> Bool
isMaybe [(Q Exp, Type, Name)]
argCons
#if MIN_VERSION_base(4,16,0)
            maybes = maybes0
            rest   = rest0
#else
            ([(Q Exp, Type, Name)]
options, [(Q Exp, Type, Name)]
rest) = ((Q Exp, Type, Name) -> Bool)
-> [(Q Exp, Type, Name)]
-> ([(Q Exp, Type, Name)], [(Q Exp, Type, Name)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Q Exp, Type, Name) -> Bool
forall a b. (a, Type, b) -> Bool
isOption [(Q Exp, Type, Name)]
rest0
            maybes :: [(Q Exp, Type, Name)]
maybes = [(Q Exp, Type, Name)]
maybes0 [(Q Exp, Type, Name)]
-> [(Q Exp, Type, Name)] -> [(Q Exp, Type, Name)]
forall a. [a] -> [a] -> [a]
++ ((Q Exp, Type, Name) -> (Q Exp, Type, Name))
-> [(Q Exp, Type, Name)] -> [(Q Exp, Type, Name)]
forall a b. (a -> b) -> [a] -> [b]
map (Q Exp, Type, Name) -> (Q Exp, Type, Name)
forall b c. (Q Exp, b, c) -> (Q Exp, b, c)
optionToMaybe [(Q Exp, Type, Name)]
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 :: [Char]
fieldName = Options -> Name -> [Char]
fieldLabel Options
opts Name
field
                  e :: Q Exp -> Q Exp
e Q Exp
arg' = (ShortByteString -> Q Exp) -> ToJSONFun -> [Char] -> Q Exp -> Q Exp
pairE ShortByteString -> Q Exp
letInsert ToJSONFun
target [Char]
fieldName (Q Exp
toValue Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
arg')
              in if Bool
lifted
                then do
                  Name
x <- [Char] -> Q Name
newName [Char]
"x"
                  [|maybe mempty|] Q Exp -> Q Exp -> Q Exp
`appE` PatQ -> Q Exp -> Q Exp
lam1E (Name -> PatQ
varP Name
x) (Q Exp -> Q Exp
e (Name -> Q Exp
varE Name
x)) Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
arg
                else Q Exp -> Q Exp
e Q Exp
arg

        PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
conName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
args)
              (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
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 ([Type] -> Bool
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] <- (Type -> Q Type) -> [Type] -> Q [Type]
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 <- [Char] -> Q Name
newName [Char]
"argL"
    Name
ar <- [Char] -> Q Name
newName [Char]
"argR"
    PatQ -> BodyQ -> [DecQ] -> MatchQ
match (PatQ -> Name -> PatQ -> PatQ
infixP (Name -> PatQ
varP Name
al) Name
conName (Name -> PatQ
varP Name
ar))
          ( Q Exp -> BodyQ
normalB
          (Q Exp -> BodyQ) -> Q Exp -> BodyQ
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
          (Q Exp -> Q Exp) -> Q Exp -> Q Exp
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
                  Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
a
              | (Name
a, Type
aTy) <- [(Name
al,Type
alTy), (Name
ar,Type
arTy)]
              ]
          )
          []

isMaybe :: (a, Type, b) -> Bool
isMaybe :: (a, Type, b) -> Bool
isMaybe (a
_, AppT (ConT Name
t) Type
_, b
_) = Name
t Name -> Name -> Bool
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 :: (a, Type, b) -> Bool
isOption (a
_, AppT (ConT Name
t) Type
_, b
_) = Name
t Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Semigroup.Option
isOption (a, Type, b)
_                       = Bool
False

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

(<^>) :: ExpQ -> ExpQ -> ExpQ
<^> :: Q Exp -> Q Exp -> Q Exp
(<^>) Q Exp
a Q Exp
b = Q Exp -> Q Exp -> Q Exp -> Q 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|] Q Exp -> Q Exp -> Q Exp
`appE` (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
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 <- [Char] -> Q Name
newName [Char]
"mv"
  let newMV :: StmtQ
newMV = PatQ -> Q Exp -> StmtQ
bindS (Name -> PatQ
varP Name
mv)
                    ([|VM.unsafeNew|] Q Exp -> Q Exp -> Q Exp
`appE`
                      Lit -> Q Exp
litE (Integer -> Lit
integerL (Integer -> Lit) -> Integer -> Lit
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Q Exp] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q Exp]
es)))
      stmts :: [StmtQ]
stmts = [ Q Exp -> StmtQ
noBindS (Q Exp -> StmtQ) -> Q Exp -> StmtQ
forall a b. (a -> b) -> a -> b
$
                  [|VM.unsafeWrite|] Q Exp -> Q Exp -> Q Exp
`appE`
                    Name -> Q Exp
varE Name
mv Q Exp -> Q Exp -> Q Exp
`appE`
                      Lit -> Q Exp
litE (Integer -> Lit
integerL Integer
ix) Q Exp -> Q Exp -> Q Exp
`appE`
                        Q Exp
e
              | (Integer
ix, Q Exp
e) <- [Integer] -> [Q Exp] -> [(Integer, Q Exp)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Integer
0::Integer)..] [Q Exp]
es
              ]
      ret :: StmtQ
ret = Q Exp -> StmtQ
noBindS (Q Exp -> StmtQ) -> Q Exp -> StmtQ
forall a b. (a -> b) -> a -> b
$ [|return|] Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
mv
  [|Array|] Q Exp -> Q Exp -> Q Exp
`appE`
             (Name -> Q Exp
varE 'V.create Q Exp -> Q Exp -> Q Exp
`appE`
               [StmtQ] -> Q Exp
doE (StmtQ
newMVStmtQ -> [StmtQ] -> [StmtQ]
forall a. a -> [a] -> [a]
:[StmtQ]
stmts[StmtQ] -> [StmtQ] -> [StmtQ]
forall a. [a] -> [a] -> [a]
++[StmtQ
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 -> [([Char], Q Exp)] -> Q Exp
objectE ShortByteString -> Q Exp
letInsert ToJSONFun
target = ToJSONFun -> Q Exp -> Q Exp
fromPairsE ToJSONFun
target (Q Exp -> Q Exp)
-> ([([Char], Q Exp)] -> Q Exp) -> [([Char], Q Exp)] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Exp] -> Q Exp
mconcatE ([Q Exp] -> Q Exp)
-> ([([Char], Q Exp)] -> [Q Exp]) -> [([Char], Q Exp)] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char], Q Exp) -> Q Exp) -> [([Char], Q Exp)] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Char] -> Q Exp -> Q Exp) -> ([Char], Q Exp) -> Q Exp
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((ShortByteString -> Q Exp) -> ToJSONFun -> [Char] -> 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) = Q Exp -> Q Exp -> Q Exp -> Q 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|] Q Exp -> Q Exp -> Q 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 -> [Char] -> Q Exp -> Q Exp
pairE ShortByteString -> Q Exp
letInsert ToJSONFun
Encoding [Char]
k Q Exp
v = [| E.unsafePairSBS |] Q Exp -> Q Exp -> Q Exp
`appE` ShortByteString -> Q Exp
letInsert ShortByteString
k' Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
v
  where
    k' :: ShortByteString
k' = ShortText -> ShortByteString
ST.toShortByteString (ShortText -> ShortByteString) -> ShortText -> ShortByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> ShortText
ST.pack ([Char] -> ShortText) -> [Char] -> ShortText
forall a b. (a -> b) -> a -> b
$ [Char]
"\"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Char -> [Char]) -> [Char] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> [Char]
escapeAscii [Char]
k [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\":"

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

pairE ShortByteString -> Q Exp
_letInsert ToJSONFun
Value    [Char]
k Q Exp
v = [| pair (Key.fromString k) |] Q Exp -> Q Exp -> Q 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]
_ [] = [Char] -> Q Exp
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Data.Aeson.TH.consFromJSON: "
                                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Not a single constructor given!"

consFromJSON JSONClass
jc Name
tName Options
opts [Type]
instTys [ConstructorInfo]
cons = do
  Name
value <- [Char] -> Q Name
newName [Char]
"value"
  [Name]
pjs   <- [Char] -> Int -> Q [Name]
newNameList [Char]
"_pj"  (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ JSONClass -> Int
arityInt JSONClass
jc
  [Name]
pjls  <- [Char] -> Int -> Q [Name]
newNameList [Char]
"_pjl" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ JSONClass -> Int
arityInt JSONClass
jc
  let zippedPJs :: [(Name, Name)]
zippedPJs      = [Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
pjs [Name]
pjls
      interleavedPJs :: [Name]
interleavedPJs = [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
interleave [Name]
pjs [Name]
pjls
      lastTyVars :: [Name]
lastTyVars     = (Type -> Name) -> [Type] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Name
varTToName ([Type] -> [Name]) -> [Type] -> [Name]
forall a b. (a -> b) -> a -> b
$ Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
drop ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
instTys Int -> Int -> Int
forall a. Num a => a -> a -> a
- JSONClass -> Int
arityInt JSONClass
jc) [Type]
instTys
      tvMap :: Map Name (Name, Name)
tvMap          = [(Name, (Name, Name))] -> Map Name (Name, Name)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, (Name, Name))] -> Map Name (Name, Name))
-> [(Name, (Name, Name))] -> Map Name (Name, Name)
forall a b. (a -> b) -> a -> b
$ [Name] -> [(Name, Name)] -> [(Name, (Name, Name))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
lastTyVars [(Name, Name)]
zippedPJs
  [PatQ] -> Q Exp -> Q Exp
lamE ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP ([Name] -> [PatQ]) -> [Name] -> [PatQ]
forall a b. (a -> b) -> a -> b
$ [Name]
interleavedPJs [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name
value]) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
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 = JSONClass -> Map Name (Name, Name) -> [Type] -> Name -> Q a -> Q a
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)
            -> Map Name (Name, Name) -> ConstructorInfo -> Q Exp -> Q Exp
forall a. Map Name (Name, Name) -> ConstructorInfo -> Q a -> Q a
checkExi Map Name (Name, Name)
tvMap ConstructorInfo
con (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ JSONClass
-> Map Name (Name, Name)
-> Name
-> Options
-> ConstructorInfo
-> Either ([Char], Name) Name
-> Q Exp
parseArgs JSONClass
jc Map Name (Name, Name)
tvMap Name
tName Options
opts ConstructorInfo
con (Name -> Either ([Char], Name) Name
forall a b. b -> Either a b
Right Name
value)
      [ConstructorInfo]
_ | Options -> SumEncoding
sumEncoding Options
opts SumEncoding -> SumEncoding -> Bool
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
            -> Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
value) ([MatchQ] -> Q Exp) -> [MatchQ] -> Q Exp
forall a b. (a -> b) -> a -> b
$
                   if Options -> Bool
allNullaryToStringTag Options
opts Bool -> Bool -> Bool
&& (ConstructorInfo -> Bool) -> [ConstructorInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ConstructorInfo -> Bool
isNullary [ConstructorInfo]
cons
                   then [MatchQ]
allNullaryMatches
                   else Map Name (Name, Name) -> [MatchQ]
mixedMatches Map Name (Name, Name)
tvMap

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

    mixedMatches :: Map Name (Name, Name) -> [MatchQ]
mixedMatches Map Name (Name, Name)
tvMap =
        case Options -> SumEncoding
sumEncoding Options
opts of
          TaggedObject {[Char]
tagFieldName :: [Char]
tagFieldName :: SumEncoding -> [Char]
tagFieldName, [Char]
contentsFieldName :: [Char]
contentsFieldName :: SumEncoding -> [Char]
contentsFieldName} ->
            (Name -> Q Exp) -> [MatchQ]
parseObject ((Name -> Q Exp) -> [MatchQ]) -> (Name -> Q Exp) -> [MatchQ]
forall a b. (a -> b) -> a -> b
$ Map Name (Name, Name) -> [Char] -> [Char] -> Name -> Q Exp
parseTaggedObject Map Name (Name, Name)
tvMap [Char]
tagFieldName [Char]
contentsFieldName
          SumEncoding
UntaggedValue -> [Char] -> [MatchQ]
forall a. HasCallStack => [Char] -> a
error [Char]
"UntaggedValue: Should be handled already"
          SumEncoding
ObjectWithSingleField ->
            (Name -> Q Exp) -> [MatchQ]
parseObject ((Name -> Q Exp) -> [MatchQ]) -> (Name -> Q Exp) -> [MatchQ]
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 <- [Char] -> Q Name
newName [Char]
"array"
                 PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP 'Array [Name -> PatQ
varP Name
arr])
                       ([Q (Guard, Exp)] -> BodyQ
guardedB
                        [ (Guard -> Exp -> (Guard, Exp))
-> Q Guard -> Q Exp -> Q (Guard, Exp)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (Q Exp -> Q Guard
normalG (Q Exp -> Q Guard) -> Q Exp -> Q Guard
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp ([|V.length|] Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
arr)
                                                         [|(==)|]
                                                         (Lit -> Q Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
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)
                        , (Guard -> Exp -> (Guard, Exp))
-> Q Guard -> Q Exp -> Q (Guard, Exp)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (Q Exp -> Q Guard
normalG [|otherwise|])
                                     ([|not2ElemArray|]
                                       Q Exp -> Q Exp -> Q Exp
`appE` Lit -> Q Exp
litE ([Char] -> Lit
stringL ([Char] -> Lit) -> [Char] -> Lit
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
tName)
                                       Q Exp -> Q Exp -> Q Exp
`appE` ([|V.length|] Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
arr))
                        ]
                       )
                       []
            , do Name
other <- [Char] -> Q Name
newName [Char]
"other"
                 PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Name -> PatQ
varP Name
other)
                       ( Q Exp -> BodyQ
normalB
                         (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ [|noArrayFail|]
                             Q Exp -> Q Exp -> Q Exp
`appE` Lit -> Q Exp
litE ([Char] -> Lit
stringL ([Char] -> Lit) -> [Char] -> Lit
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
tName)
                             Q Exp -> Q Exp -> Q Exp
`appE` ([|valueConName|] Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
other)
                       )
                       []
            ]

    parseObject :: (Name -> Q Exp) -> [MatchQ]
parseObject Name -> Q Exp
f =
        [ do Name
obj <- [Char] -> Q Name
newName [Char]
"obj"
             PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP 'Object [Name -> PatQ
varP Name
obj]) (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
f Name
obj) []
        , do Name
other <- [Char] -> Q Name
newName [Char]
"other"
             PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Name -> PatQ
varP Name
other)
                   ( Q Exp -> BodyQ
normalB
                     (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ [|noObjectFail|]
                         Q Exp -> Q Exp -> Q Exp
`appE` Lit -> Q Exp
litE ([Char] -> Lit
stringL ([Char] -> Lit) -> [Char] -> Lit
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
tName)
                         Q Exp -> Q Exp -> Q Exp
`appE` ([|valueConName|] Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
other)
                   )
                   []
        ]

    parseTaggedObject :: Map Name (Name, Name) -> [Char] -> [Char] -> Name -> Q Exp
parseTaggedObject Map Name (Name, Name)
tvMap [Char]
typFieldName [Char]
valFieldName Name
obj = do
      Name
conKey <- [Char] -> Q Name
newName [Char]
"conKeyX"
      [StmtQ] -> Q Exp
doE [ PatQ -> Q Exp -> StmtQ
bindS (Name -> PatQ
varP Name
conKey)
                  (Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
varE Name
obj)
                            [|(.:)|]
                            ([|Key.fromString|] Q Exp -> Q Exp -> Q Exp
`appE` [Char] -> Q Exp
stringE [Char]
typFieldName))
          , Q Exp -> StmtQ
noBindS (Q Exp -> StmtQ) -> Q Exp -> StmtQ
forall a b. (a -> b) -> a -> b
$ Map Name (Name, Name)
-> Name
-> Either ([Char], Name) Name
-> Name
-> Q Exp
-> Q Exp
-> Q Exp
parseContents Map Name (Name, Name)
tvMap Name
conKey (([Char], Name) -> Either ([Char], Name) Name
forall a b. a -> Either a b
Left ([Char]
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 =
        (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Q Exp
e Q Exp
e' -> Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp Q Exp
e [|(<|>)|] Q Exp
e')
               ((ConstructorInfo -> Q Exp) -> [ConstructorInfo] -> [Q Exp]
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 <- [Char] -> Q Name
newName [Char]
"str"
      Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
conVal)
        [ PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP 'String [Name -> PatQ
varP Name
str])
                ([Q (Guard, Exp)] -> BodyQ
guardedB
                  [ (Guard -> Exp -> (Guard, Exp))
-> Q Guard -> Q Exp -> Q (Guard, Exp)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (Q Exp -> Q Guard
normalG (Q Exp -> Q Guard) -> Q Exp -> Q Guard
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
varE Name
str) [|(==)|] (Options -> Name -> Q Exp
conTxt Options
opts Name
conName)
                               )
                               ([|pure|] Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
conE Name
conName)
                  ]
                )
                []
        , Name -> Name -> [Char] -> MatchQ
matchFailed Name
tName Name
conName [Char]
"String"
        ]
    parseValue Map Name (Name, Name)
tvMap ConstructorInfo
con Name
conVal =
      Map Name (Name, Name) -> ConstructorInfo -> Q Exp -> Q Exp
forall a. Map Name (Name, Name) -> ConstructorInfo -> Q a -> Q a
checkExi Map Name (Name, Name)
tvMap ConstructorInfo
con (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ JSONClass
-> Map Name (Name, Name)
-> Name
-> Options
-> ConstructorInfo
-> Either ([Char], Name) Name
-> Q Exp
parseArgs JSONClass
jc Map Name (Name, Name)
tvMap Name
tName Options
opts ConstructorInfo
con (Name -> Either ([Char], Name) Name
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 <- [Char] -> Q Name
newName [Char]
"conKeyY"
      Name
conVal <- [Char] -> Q Name
newName [Char]
"conValY"
      let letIx :: Name -> Integer -> DecQ
letIx Name
n Integer
ix =
              PatQ -> BodyQ -> [DecQ] -> DecQ
valD (Name -> PatQ
varP Name
n)
                   (Q Exp -> BodyQ
normalB ([|V.unsafeIndex|] Q Exp -> Q Exp -> Q Exp
`appE`
                               Name -> Q Exp
varE Name
arr Q Exp -> Q Exp -> Q Exp
`appE`
                               Lit -> Q Exp
litE (Integer -> Lit
integerL Integer
ix)))
                   []
      [DecQ] -> Q Exp -> Q Exp
letE [ Name -> Integer -> DecQ
letIx Name
conKey Integer
0
           , Name -> Integer -> DecQ
letIx Name
conVal Integer
1
           ]
           (Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
conKey)
                  [ do Name
txt <- [Char] -> Q Name
newName [Char]
"txtY"
                       PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP 'String [Name -> PatQ
varP Name
txt])
                             (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Map Name (Name, Name)
-> Name
-> Either ([Char], Name) Name
-> Name
-> Q Exp
-> Q Exp
-> Q Exp
parseContents Map Name (Name, Name)
tvMap
                                                      Name
txt
                                                      (Name -> Either ([Char], Name) Name
forall a b. b -> Either a b
Right Name
conVal)
                                                      'conNotFoundFail2ElemArray
                                                      [|T.pack|] [|T.unpack|]
                             )
                             []
                  , do Name
other <- [Char] -> Q Name
newName [Char]
"other"
                       PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Name -> PatQ
varP Name
other)
                             ( Q Exp -> BodyQ
normalB
                               (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ [|firstElemNoStringFail|]
                                     Q Exp -> Q Exp -> Q Exp
`appE` Lit -> Q Exp
litE ([Char] -> Lit
stringL ([Char] -> Lit) -> [Char] -> Lit
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
tName)
                                     Q Exp -> Q Exp -> Q Exp
`appE` ([|valueConName|] Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
other)
                             )
                             []
                  ]
           )

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

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

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

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

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

matchCases :: Either (String, Name) Name -> [MatchQ] -> Q Exp
matchCases :: Either ([Char], Name) Name -> [MatchQ] -> Q Exp
matchCases (Left ([Char]
valFieldName, Name
obj)) = Name -> [Char] -> [MatchQ] -> Q Exp
getValField Name
obj [Char]
valFieldName
matchCases (Right Name
valName)            = Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q 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 ([Char], 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 ([Char], Name)
_) =
    [|pure|] Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q 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) =
    Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
valName) ([MatchQ] -> Q Exp) -> [MatchQ] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Name -> [MatchQ]
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 ([Char], Name) Name
contents = do
    Type
argTy' <- Type -> Q Type
resolveTypeSynonyms Type
argTy
    Either ([Char], Name) Name -> [MatchQ] -> Q Exp
matchCases Either ([Char], Name) Name
contents ([MatchQ] -> Q Exp) -> [MatchQ] -> Q Exp
forall a b. (a -> b) -> a -> b
$ JSONClass -> Map Name (Name, Name) -> Type -> Name -> [MatchQ]
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 ([Char], Name) Name
contents = do
    [Type]
argTys' <- (Type -> Q Type) -> [Type] -> Q [Type]
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 = [Type] -> Integer
forall i a. Num i => [a] -> i
genericLength [Type]
argTys'
    Either ([Char], Name) Name -> [MatchQ] -> Q Exp
matchCases Either ([Char], Name) Name
contents ([MatchQ] -> Q Exp) -> [MatchQ] -> Q Exp
forall a b. (a -> b) -> a -> b
$ JSONClass
-> Map Name (Name, Name)
-> [Type]
-> Name
-> Name
-> Integer
-> [MatchQ]
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 ([Char]
_, Name
obj)) = do
    [Type]
argTys' <- (Type -> Q Type) -> [Type] -> Q [Type]
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 ([Char], Name) Name
-> Q Exp
parseArgs JSONClass
jc Map Name (Name, Name)
tvMap Name
tName Options
opts
                             (ConstructorInfo
info{constructorVariant :: ConstructorVariant
constructorVariant = ConstructorVariant
NormalConstructor})
                             (Name -> Either ([Char], Name) Name
forall a b. b -> Either a b
Right Name
valName)
      (Bool, [Type])
_ -> do
        Name
obj <- [Char] -> Q Name
newName [Char]
"recObj"
        [Type]
argTys' <- (Type -> Q Type) -> [Type] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms [Type]
argTys
        Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
valName)
          [ PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP 'Object [Name -> PatQ
varP Name
obj]) (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
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 -> [Char] -> MatchQ
matchFailed Name
tName Name
conName [Char]
"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 ([Char], Name) Name
contents = do
    [Type]
argTys' <- (Type -> Q Type) -> [Type] -> Q [Type]
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 ([Char], Name) Name -> [MatchQ] -> Q Exp
matchCases Either ([Char], Name) Name
contents ([MatchQ] -> Q Exp) -> [MatchQ] -> Q Exp
forall a b. (a -> b) -> a -> b
$ JSONClass
-> Map Name (Name, Name)
-> [Type]
-> Name
-> Name
-> Integer
-> [MatchQ]
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
-> [MatchQ]
parseProduct JSONClass
jc Map Name (Name, Name)
tvMap [Type]
argTys Name
tName Name
conName Integer
numArgs =
    [ do Name
arr <- [Char] -> Q Name
newName [Char]
"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
                      Q Exp -> Q Exp -> Q Exp
`appE`
                      Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
varE Name
arr)
                               [|V.unsafeIndex|]
                               (Lit -> Q Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
integerL Integer
ix)
                    | (Type
argTy, Integer
ix) <- [Type] -> [Integer] -> [(Type, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
argTys [Integer
0 .. Integer
numArgs Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1]
                    ]
         PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP 'Array [Name -> PatQ
varP Name
arr])
               (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp -> Q Exp
condE ( Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp ([|V.length|] Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
arr)
                                           [|(==)|]
                                           (Lit -> Q Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
integerL Integer
numArgs)
                                )
                                ( (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Q Exp
a Q Exp
b -> Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp Q Exp
a [|(<*>)|] Q Exp
b)
                                         (Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
conE Name
conName) [|(<$>)|] Q Exp
x)
                                         [Q Exp]
xs
                                )
                                ( Name -> Name -> Q Exp -> Q Exp -> Q Exp
parseTypeMismatch Name
tName Name
conName
                                    (Lit -> Q Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char] -> Lit
stringL ([Char] -> Lit) -> [Char] -> Lit
forall a b. (a -> b) -> a -> b
$ [Char]
"Array of length " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
numArgs)
                                    ( Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Lit -> Q Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char] -> Lit
stringL [Char]
"Array of length ")
                                               [|(++)|]
                                               ([|show . V.length|] Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
arr)
                                    )
                                )
               )
               []
    , Name -> Name -> [Char] -> MatchQ
matchFailed Name
tName Name
conName [Char]
"Array"
    ]

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

matchFailed :: Name -> Name -> String -> MatchQ
matchFailed :: Name -> Name -> [Char] -> MatchQ
matchFailed Name
tName Name
conName [Char]
expected = do
  Name
other <- [Char] -> Q Name
newName [Char]
"other"
  PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Name -> PatQ
varP Name
other)
        ( Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Q Exp -> Q Exp -> Q Exp
parseTypeMismatch Name
tName Name
conName
                      (Lit -> Q Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char] -> Lit
stringL [Char]
expected)
                      ([|valueConName|] Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q 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 =
    (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
appE
          [|parseTypeMismatch'|]
          [ Lit -> Q Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char] -> Lit
stringL ([Char] -> Lit) -> [Char] -> Lit
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
nameBase Name
conName
          , Lit -> Q Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char] -> Lit
stringL ([Char] -> Lit) -> [Char] -> Lit
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
forall a. Show a => a -> [Char]
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)
-> [Char] -> [Char] -> Object -> Key -> Parser a
lookupField = (Value -> Parser a)
-> [Char] -> [Char] -> Object -> Key -> Parser a
forall a.
(Value -> Parser a)
-> [Char] -> [Char] -> Object -> Key -> Parser a
lookupFieldWith

instance {-# INCOHERENT #-} LookupField (Maybe a) where
    lookupField :: (Value -> Parser (Maybe a))
-> [Char] -> [Char] -> Object -> Key -> Parser (Maybe a)
lookupField Value -> Parser (Maybe a)
pj [Char]
_ [Char]
_ = (Value -> Parser (Maybe a)) -> Object -> Key -> Parser (Maybe a)
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 :: (Value -> Parser (Option a))
-> [Char] -> [Char] -> Object -> Key -> Parser (Option a)
lookupField Value -> Parser (Option a)
pj [Char]
tName [Char]
rec Object
obj Key
key =
        (Maybe a -> Option a) -> Parser (Maybe a) -> Parser (Option a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe a -> Option a
forall a. Maybe a -> Option a
Semigroup.Option
             ((Value -> Parser (Maybe a))
-> [Char] -> [Char] -> Object -> Key -> Parser (Maybe a)
forall a.
LookupField a =>
(Value -> Parser a)
-> [Char] -> [Char] -> Object -> Key -> Parser a
lookupField ((Option a -> Maybe a) -> Parser (Option a) -> Parser (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Option a -> Maybe a
forall a. Option a -> Maybe a
Semigroup.getOption (Parser (Option a) -> Parser (Maybe a))
-> (Value -> Parser (Option a)) -> Value -> Parser (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser (Option a)
pj) [Char]
tName [Char]
rec Object
obj Key
key)
#endif

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

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

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

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

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

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

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

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

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

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

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

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

parseTypeMismatch' :: String -> String -> String -> String -> Parser fail
parseTypeMismatch' :: [Char] -> [Char] -> [Char] -> [Char] -> Parser fail
parseTypeMismatch' [Char]
conName [Char]
tName [Char]
expected [Char]
actual =
    [Char] -> Parser fail
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser fail) -> [Char] -> Parser fail
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char] -> [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"When parsing the constructor %s of type %s expected %s but got %s."
                  [Char]
conName [Char]
tName [Char]
expected [Char]
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 =
    ([Dec] -> [Dec] -> [Dec]) -> Q [Dec] -> Q [Dec] -> Q [Dec]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 [Dec] -> [Dec] -> [Dec]
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
      (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> DecQ -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Type] -> Q Type -> [DecQ] -> DecQ
instanceD ([Type] -> Q [Type]
forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
instanceCxt)
                          (Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceType)
                          (Name -> [Type] -> [ConstructorInfo] -> [DecQ]
methodDecs Name
parentName [Type]
instTys [ConstructorInfo]
cons)
  where
    methodDecs :: Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
    methodDecs :: Name -> [Type] -> [ConstructorInfo] -> [DecQ]
methodDecs Name
parentName [Type]
instTys [ConstructorInfo]
cons = (((JSONFun,
   JSONClass
   -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
  -> DecQ)
 -> [(JSONFun,
      JSONClass
      -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)]
 -> [DecQ])
-> [(JSONFun,
     JSONClass
     -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)]
-> ((JSONFun,
     JSONClass
     -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
    -> DecQ)
-> [DecQ]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((JSONFun,
  JSONClass
  -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
 -> DecQ)
-> [(JSONFun,
     JSONClass
     -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)]
-> [DecQ]
forall a b. (a -> b) -> [a] -> [b]
map [(JSONFun,
  JSONClass
  -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)]
consFuns (((JSONFun,
   JSONClass
   -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
  -> DecQ)
 -> [DecQ])
-> ((JSONFun,
     JSONClass
     -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
    -> DecQ)
-> [DecQ]
forall a b. (a -> b) -> a -> b
$ \(JSONFun
jf, JSONClass
-> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
jfMaker) ->
      Name -> [ClauseQ] -> DecQ
funD (JSONFun -> Arity -> Name
jsonFunValName JSONFun
jf (JSONClass -> Arity
arity JSONClass
jc))
           [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause []
                    (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
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) =
    Name -> Q Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ case Name -> Map Name (Name, Name) -> Maybe (Name, Name)
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]
_ [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 = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (JSONClass -> Int
arityInt JSONClass
jc) ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyArgs)

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

        tyVarNames :: [Name]
        tyVarNames :: [Name]
tyVarNames = Map Name (Name, Name) -> [Name]
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 (Type -> Bool) -> [Type] -> Bool
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 JSONClass -> Name -> Q Exp
forall a. JSONClass -> Name -> a
outOfPlaceTyVarError JSONClass
jc Name
conName
       else if (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`mentionsName` [Name]
tyVarNames) [Type]
rhsArgs
            then [Q Exp] -> Q Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE (Bool -> JSONFun -> Arity -> Name
jsonFunValOrListName Bool
list JSONFun
jf (Arity -> Name) -> Arity -> Name
forall a b. (a -> b) -> a -> b
$ Int -> Arity
forall a. Enum a => Int -> a
toEnum Int
numLastArgs)
                         Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Bool -> Type -> Q Exp) -> [Bool] -> [Type] -> [Q Exp]
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)
                                   ([Bool] -> [Bool]
forall a. [a] -> [a]
cycle [Bool
False,Bool
True])
                                   ([Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
interleave [Type]
rhsArgs [Type]
rhsArgs)
            else Name -> Q Exp
varE (Name -> Q Exp) -> Name -> Q Exp
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 <- (Type -> Q Type) -> [Type] -> Q [Type]
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 = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
varTysOrig Int -> Int -> Int
forall a. Num a => a -> a -> a
- JSONClass -> Int
arityInt JSONClass
jc

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

        droppedStarKindStati :: [StarKindStatus]
        droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati = (Type -> StarKindStatus) -> [Type] -> [StarKindStatus]
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.
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
remainingLength Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| StarKindStatus -> [StarKindStatus] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem StarKindStatus
NotKindStar [StarKindStatus]
droppedStarKindStati) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      JSONClass -> Name -> Q ()
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 = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar [Name]
droppedKindVarNames) [Type]
varTysExp

        remainingTysExpSubst, droppedTysExpSubst :: [Type]
        ([Type]
remainingTysExpSubst, [Type]
droppedTysExpSubst) =
          Int -> [Type] -> ([Type], [Type])
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 = [Type] -> [Name]
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.
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
hasKindStar [Type]
droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      JSONClass -> Name -> Q ()
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) = [(Maybe Type, [Name])] -> ([Maybe Type], [[Name]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Maybe Type, [Name])] -> ([Maybe Type], [[Name]]))
-> [(Maybe Type, [Name])] -> ([Maybe Type], [[Name]])
forall a b. (a -> b) -> a -> b
$ (Type -> (Maybe Type, [Name])) -> [Type] -> [(Maybe Type, [Name])]
forall a b. (a -> b) -> [a] -> [b]
map (JSONClass -> Type -> (Maybe Type, [Name])
deriveConstraint JSONClass
jc) [Type]
remainingTysExpSubst
        kvNames' :: [Name]
kvNames' = [[Name]] -> [Name]
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' =
          (Type -> Type) -> [Type] -> [Type]
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 =
          (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> Type -> Type
substNamesWithKindStar ([Name]
droppedKindVarNames [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
`union` [Name]
kvNames'))
            ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ Int -> [Type] -> [Type]
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 (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
unSigT [Type]
remainingTysOrigSubst

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

        instanceType :: Type
        instanceType :: Type
instanceType = Type -> Type -> Type
AppT (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ JSONClass -> Name
jsonClassName JSONClass
jc)
                     (Type -> Type) -> Type -> Type
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.
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`predMentionsName` [Name]
droppedTyVarNames) [Type]
dataCxt) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      Name -> Type -> Q ()
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.
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Type] -> [Type] -> Bool
canEtaReduce [Type]
remainingTysExpSubst' [Type]
droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      Type -> Q ()
forall a. Type -> Q a
etaReductionError Type
instanceType
    ([Type], Type) -> Q ([Type], Type)
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) = (Maybe Type
forall a. Maybe a
Nothing, [])
  | Type -> Bool
hasKindStar Type
t   = (Type -> Maybe Type
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 Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
>= Arity
Arity1
              -> (Type -> Maybe Type
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 Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
Arity2
                   -> (Type -> Maybe Type
forall a. a -> Maybe a
Just (Name -> Name -> Type
applyCon (Arity -> Name
jcConstraint Arity
Arity2) Name
tName), [Name]
ns)
           Maybe [Name]
_ -> (Maybe Type
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 (JSONClass -> Name) -> (Arity -> JSONClass) -> Arity -> Name
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 :: 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 ((Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> [Name] -> Bool
`predMentionsName` Map Name (Name, Name) -> [Name]
forall k a. Map k a -> [k]
M.keys Map Name (Name, Name)
tvMap) [Type]
ctxt
       Bool -> Bool -> Bool
|| Map Name (Name, Name) -> Int
forall k a. Map k a -> Int
M.size Map Name (Name, Name)
tvMap Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< JSONClass -> Int
arityInt JSONClass
jc)
       Bool -> Bool -> Bool
&& Bool -> Bool
not (JSONClass -> Bool
allowExQuant JSONClass
jc)
     then Name -> Q a
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 :: [Char] -> Int -> Q [Name]
newNameList [Char]
prefix Int
len = ([Char] -> Q Name) -> [[Char]] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [Char] -> Q Name
newName [[Char]
prefix [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
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 (NonEmpty Type -> Int
forall a. NonEmpty a -> Int
NE.length NonEmpty Type
uk Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
kindArrows) Bool -> Bool -> Bool
&& (Type -> Bool) -> NonEmpty Type -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
F.all Type -> Bool
isStarOrVar NonEmpty Type
uk
        then [Name] -> Maybe [Name]
forall a. a -> Maybe a
Just ((Type -> [Name]) -> NonEmpty Type -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables NonEmpty Type
uk)
        else Maybe [Name]
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)   = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
varTToNameMaybe (SigT Type
t Type
_) = Type -> Maybe Name
varTToNameMaybe Type
t
varTToNameMaybe Type
_          = Maybe Name
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 = Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Name
forall a. HasCallStack => [Char] -> a
error [Char]
"Not a type variable!") (Maybe Name -> Name) -> (Type -> Maybe Name) -> Type -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe Name
varTToNameMaybe

interleave :: [a] -> [a] -> [a]
interleave :: [a] -> [a] -> [a]
interleave (a
a1:[a]
a1s) (a
a2:[a]
a2s) = a
a1a -> [a] -> [a]
forall a. a -> [a] -> [a]
:a
a2a -> [a] -> [a]
forall a. a -> [a] -> [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 = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Type -> [Type] -> Type)
-> (Name -> Type) -> Name -> [Type] -> Type
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
_           -> Bool -> Q Bool
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]
_
          -> [TyVarBndr] -> Q Bool
forall a. [a] -> Q Bool
withinFirstArgs [TyVarBndr]
bndrs
        FamilyI (ClosedTypeFamilyD (TypeFamilyHead Name
_ [TyVarBndr]
bndrs FamilyResultSig
_ Maybe InjectivityAnn
_) [TySynEqn]
_) [Dec]
_
          -> [TyVarBndr] -> Q Bool
forall a. [a] -> Q Bool
withinFirstArgs [TyVarBndr]
bndrs
#else
        FamilyI (FamilyD TypeFam _ bndrs _) _
          -> withinFirstArgs bndrs
        FamilyI (ClosedTypeFamilyD _ bndrs _ _) _
          -> withinFirstArgs bndrs
#endif
        Info
_ -> Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      where
        withinFirstArgs :: [a] -> Q Bool
        withinFirstArgs :: [a] -> Q Bool
withinFirstArgs [a]
bndrs =
          let firstArgs :: [Type]
firstArgs = Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
bndrs) [Type]
tyArgs
              argFVs :: [Name]
argFVs    = [Type] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables [Type]
firstArgs
          in Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Q Bool) -> Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> [Name] -> Bool
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 :: [a] -> Bool
allDistinct = Set a -> [a] -> Bool
forall a. Ord a => Set a -> [a] -> Bool
allDistinct' Set a
forall a. Set a
Set.empty
  where
    allDistinct' :: Ord a => Set a -> [a] -> Bool
    allDistinct' :: Set a -> [a] -> Bool
allDistinct' Set a
uniqs (a
x:[a]
xs)
        | a
x a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
uniqs = Bool
False
        | Bool
otherwise            = Set a -> [a] -> Bool
forall a. Ord a => Set a -> [a] -> Bool
allDistinct' (a -> Set a -> Set a
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 Name -> [Name] -> Bool
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 = NonEmpty Type -> NonEmpty Type
forall a. NonEmpty a -> NonEmpty a
NE.reverse (NonEmpty Type -> NonEmpty Type)
-> (Type -> NonEmpty Type) -> Type -> NonEmpty Type
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 Type -> NonEmpty Type -> NonEmpty Type
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]
_ [Type]
_ Type
t) = Type -> NonEmpty Type
go Type
t
    go Type
t               = Type
t Type -> [Type] -> NonEmpty Type
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 Type -> NonEmpty Type -> NonEmpty Type
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]
_ [Type]
ctxt Type
t) =
  let ([Type]
ctxt', NonEmpty Type
tys) = Type -> ([Type], NonEmpty Type)
uncurryTy Type
t
  in ([Type]
ctxt [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
ctxt', NonEmpty Type
tys)
uncurryTy Type
t = ([], Type
t Type -> [Type] -> NonEmpty Type
forall a. a -> [a] -> NonEmpty a
:| [])

-- | Like uncurryType, except on a kind level.
uncurryKind :: Kind -> NonEmpty Kind
uncurryKind :: Type -> NonEmpty Type
uncurryKind = ([Type], NonEmpty Type) -> NonEmpty Type
forall a b. (a, b) -> b
snd (([Type], NonEmpty Type) -> NonEmpty Type)
-> (Type -> ([Type], NonEmpty Type)) -> Type -> NonEmpty Type
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 Int -> Int -> Int
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 = Lit -> Q Exp
litE
                (Lit -> Q Exp)
-> (ConstructorInfo -> Lit) -> ConstructorInfo -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Lit
stringL
                ([Char] -> Lit)
-> (ConstructorInfo -> [Char]) -> ConstructorInfo -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> [Char] -> [Char]
constructorTagModifier Options
opts
                ([Char] -> [Char])
-> (ConstructorInfo -> [Char]) -> ConstructorInfo -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
nameBase
                (Name -> [Char])
-> (ConstructorInfo -> Name) -> ConstructorInfo -> [Char]
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 -> [Char]
fieldLabel Options
opts = Options -> [Char] -> [Char]
fieldLabelModifier Options
opts ([Char] -> [Char]) -> (Name -> [Char]) -> Name -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
nameBase

-- | The name of the outermost 'Value' constructor.
valueConName :: Value -> String
valueConName :: Value -> [Char]
valueConName (Object Object
_) = [Char]
"Object"
valueConName (Array  Array
_) = [Char]
"Array"
valueConName (String Text
_) = [Char]
"String"
valueConName (Number Scientific
_) = [Char]
"Number"
valueConName (Bool   Bool
_) = [Char]
"Boolean"
valueConName Value
Null       = [Char]
"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 =
       (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isTyVar [Type]
dropped
    Bool -> Bool -> Bool
&& [Name] -> 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 ((Type -> Bool) -> [Type] -> Bool
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 = (Type -> Name) -> [Type] -> [Name]
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 = Map Name Type -> Type -> Type
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 (Name -> Type -> Map Name Type
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 = (Name -> Type -> Type) -> Type -> [Name] -> Type
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 :: JSONClass -> Name -> Q a
derivingKindError JSONClass
jc Name
tyConName = [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail
  ([Char] -> Q a) -> ([Char] -> [Char]) -> [Char] -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
showString [Char]
"Cannot derive well-kinded instance of form ‘"
  ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
showString [Char]
className
  ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> [Char] -> [Char]
showChar Char
' '
  ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ([Char] -> [Char]) -> [Char] -> [Char]
showParen Bool
True
    ( [Char] -> [Char] -> [Char]
showString (Name -> [Char]
nameBase Name
tyConName)
    ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
showString [Char]
" ..."
    )
  ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
showString [Char]
"‘\n\tClass "
  ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
showString [Char]
className
  ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
showString [Char]
" expects an argument of kind "
  ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
showString (Type -> [Char]
forall a. Ppr a => a -> [Char]
pprint (Type -> [Char]) -> (Int -> Type) -> Int -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type
createKindChain (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ JSONClass -> Int
arityInt JSONClass
jc)
  ([Char] -> Q a) -> [Char] -> Q a
forall a b. (a -> b) -> a -> b
$ [Char]
""
  where
    className :: String
    className :: [Char]
className = Name -> [Char]
nameBase (Name -> [Char]) -> Name -> [Char]
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 :: Type -> Q a
etaReductionError Type
instanceType = [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q a) -> [Char] -> Q a
forall a b. (a -> b) -> a -> b
$
    [Char]
"Cannot eta-reduce to an instance of form \n\tinstance (...) => "
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Ppr a => a -> [Char]
pprint Type
instanceType

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

-- | 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 :: JSONClass -> Name -> a
outOfPlaceTyVarError JSONClass
jc Name
conName = [Char] -> a
forall a. HasCallStack => [Char] -> a
error
    ([Char] -> a) -> ([Char] -> [Char]) -> [Char] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
showString [Char]
"Constructor ‘"
    ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
showString (Name -> [Char]
nameBase Name
conName)
    ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
showString [Char]
"‘ must only use its last "
    ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char] -> [Char]
forall a. Show a => a -> [Char] -> [Char]
shows Int
n
    ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
showString [Char]
" type variable(s) within the last "
    ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char] -> [Char]
forall a. Show a => a -> [Char] -> [Char]
shows Int
n
    ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
showString [Char]
" argument(s) of a data type"
    ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [Char]
""
  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 :: Name -> a
existentialContextError Name
conName = [Char] -> a
forall a. HasCallStack => [Char] -> a
error
  ([Char] -> a) -> ([Char] -> [Char]) -> [Char] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
showString [Char]
"Constructor ‘"
  ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
showString (Name -> [Char]
nameBase Name
conName)
  ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
showString [Char]
"‘ must be truly polymorphic in the last argument(s) of the data type"
  ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [Char]
""

-------------------------------------------------------------------------------
-- 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]
(Arity -> Arity)
-> (Arity -> Arity)
-> (Int -> Arity)
-> (Arity -> Int)
-> (Arity -> [Arity])
-> (Arity -> Arity -> [Arity])
-> (Arity -> Arity -> [Arity])
-> (Arity -> Arity -> Arity -> [Arity])
-> Enum 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
(Arity -> Arity -> Bool) -> (Arity -> Arity -> Bool) -> Eq Arity
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
Eq Arity
-> (Arity -> Arity -> Ordering)
-> (Arity -> Arity -> Bool)
-> (Arity -> Arity -> Bool)
-> (Arity -> Arity -> Bool)
-> (Arity -> Arity -> Bool)
-> (Arity -> Arity -> Arity)
-> (Arity -> Arity -> Arity)
-> Ord 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
$cp1Ord :: Eq Arity
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 = Arity -> Int
forall a. Enum a => a -> Int
fromEnum (Arity -> Int) -> (JSONClass -> Arity) -> JSONClass -> Int
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
(StarKindStatus -> StarKindStatus -> Bool)
-> (StarKindStatus -> StarKindStatus -> Bool) -> Eq StarKindStatus
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) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
starKindStatusToName StarKindStatus
_             = Maybe Name
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 = (StarKindStatus -> Maybe Name) -> [StarKindStatus] -> [Name]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe StarKindStatus -> Maybe Name
starKindStatusToName