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

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

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

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

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

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

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

Now we can use the newly created instances.

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

@
fromJSON (toJSON d) == Success d
@

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

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

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

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

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

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

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

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

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

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

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

import Data.Aeson.Internal.Prelude

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.ToJSON (fromPairs, pair)
import Data.Aeson.Key (Key)
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KM
import Data.Foldable (foldr')
import Data.List (genericLength, intercalate, union)
import Data.List.NonEmpty ((<|), NonEmpty((:|)))
import Data.Map (Map)
import qualified Data.Monoid as Monoid
import Data.Set (Set)
import Language.Haskell.TH hiding (Arity)
import Language.Haskell.TH.Datatype
import Text.Printf (printf)
import qualified Data.Aeson.Encoding.Internal as E
import qualified Data.List.NonEmpty as NE (length, reverse)
import qualified Data.Map as M (fromList, keys, lookup , singleton, size)
import qualified Data.Set as Set (empty, insert, member)
import qualified Data.Text as T (pack, unpack)
import qualified Data.Vector as V (unsafeIndex, null, length, create, empty)
import qualified Data.Vector.Mutable as VM (unsafeNew, unsafeWrite)
import qualified Data.Text.Short as ST
import Data.ByteString.Short (ShortByteString)
import Data.Aeson.Internal.ByteString
import Data.Aeson.Internal.TH

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

type LetInsert = ShortByteString -> ExpQ

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

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

consToValue ToJSONFun
target JSONClass
jc Options
opts [Type]
instTys [ConstructorInfo]
cons = (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 <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"value"
    [Name]
os    <- String -> Int -> Q [Name]
newNameList String
"_o"   (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ JSONClass -> Int
arityInt JSONClass
jc
    [Name]
tjs   <- String -> Int -> Q [Name]
newNameList String
"_tj"  (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ JSONClass -> Int
arityInt JSONClass
jc
    [Name]
tjls  <- String -> Int -> Q [Name]
newNameList String
"_tjl" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ JSONClass -> Int
arityInt JSONClass
jc
    let zippedTJs :: [(Name, Name, Name)]
zippedTJs      = [Name] -> [Name] -> [Name] -> [(Name, Name, Name)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Name]
os [Name]
tjs [Name]
tjls
        interleavedTJs :: [Name]
interleavedTJs = [(Name, Name, Name)] -> [Name]
forall a. [(a, a, a)] -> [a]
flatten3 [(Name, Name, Name)]
zippedTJs
        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 a. [a] -> 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, Name)
tvMap          = [(Name, (Name, Name, Name))] -> Map Name (Name, Name, Name)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, (Name, Name, Name))] -> Map Name (Name, Name, Name))
-> [(Name, (Name, Name, Name))] -> Map Name (Name, Name, Name)
forall a b. (a -> b) -> a -> b
$ [Name] -> [(Name, Name, Name)] -> [(Name, (Name, Name, Name))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
lastTyVars [(Name, Name, Name)]
zippedTJs
    [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP ([Name] -> [Q Pat]) -> [Name] -> [Q Pat]
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 -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value) ((ShortByteString -> Q Exp)
-> Map Name (Name, Name, Name) -> [Q Match]
matches ShortByteString -> Q Exp
letInsert Map Name (Name, Name, Name)
tvMap)
  where
    matches :: (ShortByteString -> Q Exp)
-> Map Name (Name, Name, Name) -> [Q Match]
matches ShortByteString -> Q Exp
letInsert Map Name (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, Name)
-> Options
-> Bool
-> ConstructorInfo
-> Q Match
argsToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target JSONClass
jc Map Name (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 ->
              [ Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName []) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
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, Name)
-> Options
-> Bool
-> ConstructorInfo
-> Q Match
argsToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target JSONClass
jc Map Name (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
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m 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
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m 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
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|T.pack|] (Q Exp -> Q Exp) -> (Name -> Q Exp) -> Name -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> Q Exp) -> (Name -> String) -> Name -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> Name -> String
conString Options
opts

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

-- | If constructor is nullary.
isNullary :: ConstructorInfo -> Bool
isNullary :: ConstructorInfo -> Bool
isNullary ConstructorInfo { constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
NormalConstructor
                          , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
tys } = [Type] -> Bool
forall a. [a] -> 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
-> (String -> Q Exp)
-> Q Exp
sumToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target Options
opts Bool
multiCons Bool
nullary Name
conName
    Q Exp
value
    String -> Q Exp
pairs
  where
    pairs :: String -> Q Exp
pairs String
contentsFieldName = (ShortByteString -> Q Exp) -> ToJSONFun -> String -> Q Exp -> Q Exp
pairE ShortByteString -> Q Exp
letInsert ToJSONFun
target String
contentsFieldName Q Exp
value

-- | Wrap fields of a record constructor. See 'sumToValue'.
recordSumToValue :: LetInsert -> ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ
recordSumToValue :: (ShortByteString -> Q Exp)
-> ToJSONFun -> Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp
recordSumToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target Options
opts Bool
multiCons Bool
nullary Name
conName Q Exp
pairs =
  (ShortByteString -> Q Exp)
-> ToJSONFun
-> Options
-> Bool
-> Bool
-> Name
-> Q Exp
-> (String -> Q Exp)
-> Q Exp
sumToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target Options
opts Bool
multiCons Bool
nullary Name
conName
    (ToJSONFun -> Q Exp -> Q Exp
fromPairsE ToJSONFun
target Q Exp
pairs)
    (Q Exp -> String -> 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
-> (String -> Q Exp)
-> Q Exp
sumToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target Options
opts Bool
multiCons Bool
nullary Name
conName Q Exp
value String -> Q Exp
pairs
    | Bool
multiCons =
        case Options -> SumEncoding
sumEncoding Options
opts of
          SumEncoding
TwoElemArray ->
            ToJSONFun -> [Q Exp] -> Q Exp
array ToJSONFun
target [ToJSONFun -> Options -> Name -> Q Exp
conStr ToJSONFun
target Options
opts Name
conName, Q Exp
value]
          TaggedObject{String
tagFieldName :: String
tagFieldName :: SumEncoding -> String
tagFieldName, String
contentsFieldName :: String
contentsFieldName :: SumEncoding -> String
contentsFieldName} ->
            -- TODO: Maybe throw an error in case
            -- tagFieldName overwrites a field in pairs.
            let tag :: Q Exp
tag = (ShortByteString -> Q Exp) -> ToJSONFun -> String -> Q Exp -> Q Exp
pairE ShortByteString -> Q Exp
letInsert ToJSONFun
target String
tagFieldName (ToJSONFun -> Options -> Name -> Q Exp
conStr ToJSONFun
target Options
opts Name
conName)
                content :: Q Exp
content = String -> Q Exp
pairs String
contentsFieldName
            in ToJSONFun -> Q Exp -> Q Exp
fromPairsE ToJSONFun
target (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
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
tag [|(Monoid.<>)|] Q Exp
content
          SumEncoding
ObjectWithSingleField ->
            (ShortByteString -> Q Exp)
-> ToJSONFun -> [(String, Q Exp)] -> Q Exp
objectE ShortByteString -> Q Exp
letInsert ToJSONFun
target [(Options -> Name -> String
conString Options
opts Name
conName, Q Exp
value)]
          SumEncoding
UntaggedValue | Bool
nullary -> ToJSONFun -> Options -> Name -> Q Exp
conStr ToJSONFun
target Options
opts Name
conName
          SumEncoding
UntaggedValue -> Q Exp
value
    | Bool
otherwise = Q Exp
value

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

-- Polyadic constructors with special case for unary constructors.
argsToValue :: (ShortByteString -> Q Exp)
-> ToJSONFun
-> JSONClass
-> Map Name (Name, Name, Name)
-> Options
-> Bool
-> ConstructorInfo
-> Q Match
argsToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target JSONClass
jc Map Name (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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Q Type
resolveTypeSynonyms [Type]
argTys
    let len :: Int
len = [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
argTys'
    [Name]
args <- String -> Int -> Q [Name]
newNameList String
"arg" Int
len
    let js :: Q Exp
js = case [ ToJSONFun
-> JSONClass
-> Name
-> Map Name (Name, Name, Name)
-> Type
-> Q Exp
dispatchToJSON ToJSONFun
target JSONClass
jc Name
conName Map Name (Name, Name, Name)
tvMap Type
argTy
                      Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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

    Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
args)
          (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
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 a. [a] -> 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, 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, Name)
-> Options
-> Bool
-> ConstructorInfo
-> Q Match
argsToValue ShortByteString -> Q Exp
letInsert ToJSONFun
target JSONClass
jc Map Name (Name, Name, Name)
tvMap Options
opts Bool
multiCons
                                     (ConstructorInfo
info{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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Q Type
resolveTypeSynonyms [Type]
argTys
        [Name]
args <- String -> Int -> Q [Name]
newNameList String
"arg" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
argTys'
        let 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
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
args) [Type]
argTys' [Name]
fields

            toPair :: (Q Exp, Type, Name) -> Q Exp
toPair (Q Exp
arg, Type
argTy, Name
fld) =
              let fieldName :: String
fieldName = Options -> Name -> String
fieldLabel Options
opts Name
fld
                  toValue :: Q Exp
toValue = ToJSONFun
-> JSONClass
-> Name
-> Map Name (Name, Name, Name)
-> Type
-> Q Exp
dispatchToJSON ToJSONFun
target JSONClass
jc Name
conName Map Name (Name, Name, Name)
tvMap Type
argTy

                  omitFn :: Q Exp
                  omitFn :: Q Exp
omitFn
                    | Options -> Bool
omitNothingFields Options
opts = JSONClass -> Name -> Map Name (Name, Name, Name) -> Type -> Q Exp
dispatchOmitField JSONClass
jc Name
conName Map Name (Name, Name, Name)
tvMap Type
argTy
                    | Bool
otherwise = [| const False |]

              in Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
condE
                (Q Exp
omitFn Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
arg)
                [| mempty |]
                ((ShortByteString -> Q Exp) -> ToJSONFun -> String -> Q Exp -> Q Exp
pairE ShortByteString -> Q Exp
letInsert ToJSONFun
target String
fieldName (Q Exp
toValue Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
arg))

            pairs :: Q Exp
pairs = [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
toPair [(Q Exp, Type, Name)]
argCons)

        Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
args)
              (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
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 a. [a] -> 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, 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Q Type
resolveTypeSynonyms [Type]
argTys
    Name
al <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"argL"
    Name
ar <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"argR"
    Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Q Pat -> Name -> Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> Name -> m Pat -> m Pat
infixP (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
al) Name
conName (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
ar))
          ( Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
          (Q Exp -> Q Body) -> Q Exp -> Q Body
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, Name)
-> Type
-> Q Exp
dispatchToJSON ToJSONFun
target JSONClass
jc Name
conName Map Name (Name, Name, Name)
tvMap Type
aTy
                  Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
a
              | (Name
a, Type
aTy) <- [(Name
al,Type
alTy), (Name
ar,Type
arTy)]
              ]
          )
          []

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

consFromJSON JSONClass
jc Name
tName Options
opts [Type]
instTys [ConstructorInfo]
cons = do
  Name
value <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"value"
  [Name]
os    <- String -> Int -> Q [Name]
newNameList String
"_o"   (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ JSONClass -> Int
arityInt JSONClass
jc
  [Name]
pjs   <- String -> Int -> Q [Name]
newNameList String
"_pj"  (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ JSONClass -> Int
arityInt JSONClass
jc
  [Name]
pjls  <- String -> Int -> Q [Name]
newNameList String
"_pjl" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ JSONClass -> Int
arityInt JSONClass
jc
  let zippedPJs :: [(Name, Name, Name)]
zippedPJs      = [Name] -> [Name] -> [Name] -> [(Name, Name, Name)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Name]
os [Name]
pjs [Name]
pjls
      interleavedPJs :: [Name]
interleavedPJs = [(Name, Name, Name)] -> [Name]
forall a. [(a, a, a)] -> [a]
flatten3 [(Name, Name, Name)]
zippedPJs
      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 a. [a] -> 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, Name)
tvMap          = [(Name, (Name, Name, Name))] -> Map Name (Name, Name, Name)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, (Name, Name, Name))] -> Map Name (Name, Name, Name))
-> [(Name, (Name, Name, Name))] -> Map Name (Name, Name, Name)
forall a b. (a -> b) -> a -> b
$ [Name] -> [(Name, Name, Name)] -> [(Name, (Name, Name, Name))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
lastTyVars [(Name, Name, Name)]
zippedPJs
  [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP ([Name] -> [Q Pat]) -> [Name] -> [Q Pat]
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, Name) -> Q Exp
lamExpr Name
value Map Name (Name, Name, Name)
tvMap

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

    lamExpr :: Name -> Map Name (Name, Name, Name) -> Q Exp
lamExpr Name
value Map Name (Name, Name, Name)
tvMap = case [ConstructorInfo]
cons of
      [ConstructorInfo
con]
        | Bool -> Bool
not (Options -> Bool
tagSingleConstructors Options
opts)
            -> Map Name (Name, Name, Name) -> ConstructorInfo -> Q Exp -> Q Exp
forall {a}.
Map Name (Name, Name, Name) -> ConstructorInfo -> Q a -> Q a
checkExi Map Name (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)
-> Name
-> Options
-> ConstructorInfo
-> Either (String, Name) Name
-> Q Exp
parseArgs JSONClass
jc Map Name (Name, Name, Name)
tvMap Name
tName Options
opts ConstructorInfo
con (Name -> Either (String, 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, Name) -> [ConstructorInfo] -> Name -> Q Exp
parseUntaggedValue Map Name (Name, Name, Name)
tvMap [ConstructorInfo]
cons Name
value
        | Bool
otherwise
            -> Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
value) ([Q Match] -> Q Exp) -> [Q Match] -> 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 [Q Match]
allNullaryMatches
                   else Map Name (Name, Name, Name) -> [Q Match]
mixedMatches Map Name (Name, Name, Name)
tvMap

    allNullaryMatches :: [Q Match]
allNullaryMatches =
      [ do Name
txt <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"txtX"
           Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'String [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
txt])
                 ([Q (Guard, Exp)] -> Q Body
forall (m :: * -> *). Quote m => [m (Guard, Exp)] -> m Body
guardedB ([Q (Guard, Exp)] -> Q Body) -> [Q (Guard, Exp)] -> Q Body
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
forall (m :: * -> *). Quote m => m Exp -> m 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
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
txt)
                                           [|(==)|]
                                           (Options -> Name -> Q Exp
conTxt Options
opts Name
conName)
                               )
                               ([|pure|] Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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
forall (m :: * -> *). Quote m => m Exp -> m Guard
normalG [|otherwise|])
                      ( [|noMatchFail|]
                        Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. Show a => a -> String
show Name
tName)
                        Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ([|T.unpack|] Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
txt)
                      )
                  ]
                 )
                 []
      , do Name
other <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"other"
           Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
other)
                 (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ [|noStringFail|]
                    Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. Show a => a -> String
show Name
tName)
                    Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ([|valueConName|] Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
other)
                 )
                 []
      ]

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

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

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

    parseUntaggedValue :: Map Name (Name, Name, Name) -> [ConstructorInfo] -> Name -> Q Exp
parseUntaggedValue Map Name (Name, Name, Name)
tvMap [ConstructorInfo]
cons' Name
conVal =
        (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> [a] -> a
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
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m 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, Name) -> ConstructorInfo -> Name -> Q Exp
parseValue Map Name (Name, Name, Name)
tvMap ConstructorInfo
x Name
conVal) [ConstructorInfo]
cons')

    parseValue :: Map Name (Name, Name, Name) -> ConstructorInfo -> Name -> Q Exp
parseValue Map Name (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 <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"str"
      Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
conVal)
        [ Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'String [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
str])
                ([Q (Guard, Exp)] -> Q Body
forall (m :: * -> *). Quote m => [m (Guard, Exp)] -> m Body
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
forall (m :: * -> *). Quote m => m Exp -> m 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
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
str) [|(==)|] (Options -> Name -> Q Exp
conTxt Options
opts Name
conName)
                               )
                               ([|pure|] Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName)
                  ]
                )
                []
        , Name -> Name -> String -> Q Match
matchFailed Name
tName Name
conName String
"String"
        ]
    parseValue Map Name (Name, Name, Name)
tvMap ConstructorInfo
con Name
conVal =
      Map Name (Name, Name, Name) -> ConstructorInfo -> Q Exp -> Q Exp
forall {a}.
Map Name (Name, Name, Name) -> ConstructorInfo -> Q a -> Q a
checkExi Map Name (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)
-> Name
-> Options
-> ConstructorInfo
-> Either (String, Name) Name
-> Q Exp
parseArgs JSONClass
jc Map Name (Name, Name, Name)
tvMap Name
tName Options
opts ConstructorInfo
con (Name -> Either (String, Name) Name
forall a b. b -> Either a b
Right Name
conVal)


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

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

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

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

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

parseRecord :: JSONClass
            -> TyVarMap
            -> [Type]
            -> Options
            -> Name
            -> Name
            -> [Name]
            -> Name
            -> Bool
            -> ExpQ
parseRecord :: JSONClass
-> Map Name (Name, Name, Name)
-> [Type]
-> Options
-> Name
-> Name
-> [Name]
-> Name
-> Bool
-> Q Exp
parseRecord JSONClass
jc Map Name (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
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m 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 b a. (b -> a -> b) -> b -> [a] -> b
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
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
a [|(<*>)|] Q Exp
b)
           (Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName) [|(<$>)|] Q Exp
x)
           [Q Exp]
xs
    where
      lookupField :: Type -> Q Exp
      lookupField :: Type -> Q Exp
lookupField Type
argTy
        | Options -> Bool
allowOmittedFields Options
opts = [| lookupFieldOmit |] Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` JSONClass -> Name -> Map Name (Name, Name, Name) -> Type -> Q Exp
dispatchOmittedField JSONClass
jc Name
conName Map Name (Name, Name, Name)
tvMap Type
argTy
        | Bool
otherwise               = [| lookupFieldNoOmit |]

      tagFieldNameAppender :: [String] -> [String]
tagFieldNameAppender =
          if Bool
inTaggedObject then (SumEncoding -> String
tagFieldName (Options -> SumEncoding
sumEncoding Options
opts) String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) else [String] -> [String]
forall a. a -> a
id
      knownFields :: Q Exp
knownFields = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|KM.fromList|] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$
          (String -> Q Exp) -> [String] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\String
knownName -> [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE [Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|Key.fromString|] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL String
knownName, [|()|]]) ([String] -> [Q Exp]) -> [String] -> [Q Exp]
forall a b. (a -> b) -> a -> b
$
              [String] -> [String]
tagFieldNameAppender ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Name -> String) -> [Name] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Options -> Name -> String
fieldLabel Options
opts) [Name]
fields
      checkUnknownRecords :: Q Exp
checkUnknownRecords =
          Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m 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
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
obj) [|KM.difference|] Q Exp
knownFields)
              [ Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match ([Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => [m Pat] -> m Pat
listP []) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|return ()|]) []
              , String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"unknownFields" Q Name -> (Name -> Q Match) -> Q Match
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                  \Name
unknownFields -> Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
unknownFields)
                      (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m 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
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp
                          (Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL String
"Unknown fields: "))
                          [|(++)|]
                          (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|show|] (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
unknownFields)))
                      []
              ]
      Q Exp
x:[Q Exp]
xs = [ Type -> Q Exp
lookupField Type
argTy
               Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` JSONClass -> Name -> Map Name (Name, Name, Name) -> Type -> Q Exp
dispatchParseJSON JSONClass
jc Name
conName Map Name (Name, Name, Name)
tvMap Type
argTy
               Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. Show a => a -> String
show Name
tName)
               Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Options -> String -> String
constructorTagModifier Options
opts (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
conName)
               Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
obj
               Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ( [|Key.fromString|] Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (Options -> Name -> String
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 -> String -> [Q Match] -> Q Exp
getValField Name
obj String
valFieldName [Q Match]
matches = do
  Name
val <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"val"
  [Q Stmt] -> Q Exp
forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
doE [ Q Pat -> Q Exp -> Q Stmt
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
bindS (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
val) (Q Exp -> Q Stmt) -> Q Exp -> Q Stmt
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
obj)
                                    [|(.:)|]
                                    ([|Key.fromString|] Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
                                       Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL String
valFieldName))
      , Q Exp -> Q Stmt
forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS (Q Exp -> Q Stmt) -> Q Exp -> Q Stmt
forall a b. (a -> b) -> a -> b
$ Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
val) [Q Match]
matches
      ]

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

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

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

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

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

-- Infix constructors. Apart from syntax these are the same as
-- polyadic constructors.
parseArgs JSONClass
jc Map Name (Name, Name, Name)
tvMap Name
tName Options
_
  ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
conName
                  , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
InfixConstructor
                  , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
argTys }
  Either (String, Name) Name
contents = do
    [Type]
argTys' <- (Type -> Q Type) -> [Type] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Q Type
resolveTypeSynonyms [Type]
argTys
    Either (String, Name) Name -> [Q Match] -> Q Exp
matchCases Either (String, Name) Name
contents ([Q Match] -> Q Exp) -> [Q Match] -> Q Exp
forall a b. (a -> b) -> a -> b
$ JSONClass
-> Map Name (Name, Name, Name)
-> [Type]
-> Name
-> Name
-> Integer
-> [Q Match]
parseProduct JSONClass
jc Map Name (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, Name)
-> [Type]
-> Name
-> Name
-> Integer
-> [Q Match]
parseProduct JSONClass
jc Map Name (Name, Name, Name)
tvMap [Type]
argTys Name
tName Name
conName Integer
numArgs =
    [ do Name
arr <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"arr"
         -- List of: "parseJSON (arr `V.unsafeIndex` <IX>)"
         let Q Exp
x:[Q Exp]
xs = [ JSONClass -> Name -> Map Name (Name, Name, Name) -> Type -> Q Exp
dispatchParseJSON JSONClass
jc Name
conName Map Name (Name, Name, Name)
tvMap Type
argTy
                      Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
                      Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
arr)
                               [|V.unsafeIndex|]
                               (Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m 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]
                    ]
         Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Array [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
arr])
               (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
condE ( Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp ([|V.length|] Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
arr)
                                           [|(==)|]
                                           (Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m 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 b a. (b -> a -> b) -> b -> [a] -> b
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
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
a [|(<*>)|] Q Exp
b)
                                         (Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName) [|(<$>)|] Q Exp
x)
                                         [Q Exp]
xs
                                )
                                ( Name -> Name -> Q Exp -> Q Exp -> Q Exp
parseTypeMismatch Name
tName Name
conName
                                    (Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ String
"Array of length " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
numArgs)
                                    ( Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL String
"Array of length ")
                                               [|(++)|]
                                               ([|show . V.length|] Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
arr)
                                    )
                                )
               )
               []
    , Name -> Name -> String -> Q Match
matchFailed Name
tName Name
conName String
"Array"
    ]

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

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

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

lookupFieldOmit :: Maybe a -> (Value -> Parser a) -> String -> String -> Object -> Key -> Parser a
lookupFieldOmit :: forall a.
Maybe a
-> (Value -> Parser a)
-> String
-> String
-> Object
-> Key
-> Parser a
lookupFieldOmit Maybe a
maybeDefault Value -> Parser a
pj String
tName String
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 ->
        case Maybe a
maybeDefault of
          Maybe a
Nothing -> String -> String -> String -> Parser a
forall fail. String -> String -> String -> Parser fail
unknownFieldFail String
tName String
rec (Key -> String
Key.toString Key
key)
          Just a
x -> a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
      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

lookupFieldNoOmit :: (Value -> Parser a) -> String -> String -> Object -> Key -> Parser a
lookupFieldNoOmit :: forall a.
(Value -> Parser a)
-> String -> String -> Object -> Key -> Parser a
lookupFieldNoOmit Value -> Parser a
pj String
tName String
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 -> String -> String -> String -> Parser a
forall fail. String -> String -> String -> Parser fail
unknownFieldFail String
tName String
rec (Key -> String
Key.toString Key
key)
      Just Value
v  -> Value -> Parser a
pj Value
v Parser a -> JSONPathElement -> Parser a
forall a. Parser a -> JSONPathElement -> Parser a
<?> Key -> JSONPathElement
Key Key
key

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

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

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

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

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

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

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

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

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

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

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

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

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

-- | Functionality common to 'deriveJSON', 'deriveJSON1', and 'deriveJSON2'.
deriveJSONBoth :: (Options -> Name -> Q [Dec])
               -- ^ Function which derives a flavor of 'ToJSON'.
               -> (Options -> Name -> Q [Dec])
               -- ^ Function which derives a flavor of 'FromJSON'.
               -> Options
               -- ^ Encoding options.
               -> Name
               -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON'
               -- instances.
               -> Q [Dec]
deriveJSONBoth :: (Options -> Name -> Q [Dec])
-> (Options -> Name -> Q [Dec]) -> Options -> Name -> Q [Dec]
deriveJSONBoth Options -> Name -> Q [Dec]
dtj Options -> Name -> Q [Dec]
dfj Options
opts Name
name =
    ([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
                 , datatypeInstTypes :: DatatypeInfo -> [Type]
datatypeInstTypes = [Type]
instTys
                 , 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]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Type] -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([Type] -> Q [Type]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
instanceCxt)
                          (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceType)
                          (Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
methodDecs Name
parentName [Type]
instTys [ConstructorInfo]
cons)
  where
    methodDecs :: Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
    methodDecs :: Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
methodDecs Name
parentName [Type]
instTys [ConstructorInfo]
cons = (((JSONFun,
   JSONClass
   -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
  -> Q Dec)
 -> [(JSONFun,
      JSONClass
      -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)]
 -> [Q Dec])
-> [(JSONFun,
     JSONClass
     -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)]
-> ((JSONFun,
     JSONClass
     -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
    -> Q Dec)
-> [Q Dec]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((JSONFun,
  JSONClass
  -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
 -> Q Dec)
-> [(JSONFun,
     JSONClass
     -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)]
-> [Q Dec]
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)
  -> Q Dec)
 -> [Q Dec])
-> ((JSONFun,
     JSONClass
     -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
    -> Q Dec)
-> [Q Dec]
forall a b. (a -> b) -> a -> b
$ \(JSONFun
jf, JSONClass
-> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
jfMaker) ->
      Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (JSONFun -> Arity -> Name
jsonFunValName JSONFun
jf (JSONClass -> Arity
arity JSONClass
jc))
           [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause []
                    (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
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
                 , datatypeInstTypes :: DatatypeInfo -> [Type]
datatypeInstTypes = [Type]
instTys
                 , 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

data FunArg = Omit | Single | Plural deriving (FunArg -> FunArg -> Bool
(FunArg -> FunArg -> Bool)
-> (FunArg -> FunArg -> Bool) -> Eq FunArg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FunArg -> FunArg -> Bool
== :: FunArg -> FunArg -> Bool
$c/= :: FunArg -> FunArg -> Bool
/= :: FunArg -> FunArg -> Bool
Eq)

dispatchFunByType :: JSONClass
                  -> JSONFun
                  -> Name
                  -> TyVarMap
                  -> FunArg -- Plural if we are using the function argument that works
                            -- on lists (e.g., [a] -> Value). Single is we are using
                            -- the function argument that works on single values
                            -- (e.g., a -> Value). Omit if we use it to check omission
                            -- (e.g. a -> Bool)
                  -> Type
                  -> Q Exp
dispatchFunByType :: JSONClass
-> JSONFun
-> Name
-> Map Name (Name, Name, Name)
-> FunArg
-> Type
-> Q Exp
dispatchFunByType JSONClass
_ JSONFun
jf Name
_ Map Name (Name, Name, Name)
tvMap FunArg
list (VarT Name
tyName) =
    Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ case Name -> Map Name (Name, Name, Name) -> Maybe (Name, Name, Name)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
tyName Map Name (Name, Name, Name)
tvMap of
                Just (Name
tfjoExp, Name
tfjExp, Name
tfjlExp) -> case FunArg
list of
                    FunArg
Omit -> Name
tfjoExp
                    FunArg
Single -> Name
tfjExp 
                    FunArg
Plural -> Name
tfjlExp
                Maybe (Name, Name, Name)
Nothing                   -> FunArg -> JSONFun -> Arity -> Name
jsonFunValOrListName FunArg
list JSONFun
jf Arity
Arity0
dispatchFunByType JSONClass
jc JSONFun
jf Name
conName Map Name (Name, Name, Name)
tvMap FunArg
list (SigT Type
ty Type
_) =
    JSONClass
-> JSONFun
-> Name
-> Map Name (Name, Name, Name)
-> FunArg
-> Type
-> Q Exp
dispatchFunByType JSONClass
jc JSONFun
jf Name
conName Map Name (Name, Name, Name)
tvMap FunArg
list Type
ty
dispatchFunByType JSONClass
jc JSONFun
jf Name
conName Map Name (Name, Name, Name)
tvMap FunArg
list (ForallT [TyVarBndr Specificity]
_ [Type]
_ Type
ty) =
    JSONClass
-> JSONFun
-> Name
-> Map Name (Name, Name, Name)
-> FunArg
-> Type
-> Q Exp
dispatchFunByType JSONClass
jc JSONFun
jf Name
conName Map Name (Name, Name, Name)
tvMap FunArg
list Type
ty
dispatchFunByType JSONClass
jc JSONFun
jf Name
conName Map Name (Name, Name, Name)
tvMap FunArg
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 a. [a] -> 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 a. [a] -> 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) -> [Name]
forall k a. Map k a -> [k]
M.keys Map Name (Name, Name, Name)
tvMap

        args :: [Q Exp]
        args :: [Q Exp]
args
            | FunArg
list FunArg -> FunArg -> Bool
forall a. Eq a => a -> a -> Bool
== FunArg
Omit = (Type -> Q Exp) -> [Type] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map     (JSONClass
-> JSONFun
-> Name
-> Map Name (Name, Name, Name)
-> FunArg
-> Type
-> Q Exp
dispatchFunByType JSONClass
jc JSONFun
jf Name
conName Map Name (Name, Name, Name)
tvMap  FunArg
Omit)                        [Type]
rhsArgs
            | Bool
otherwise    = (FunArg -> Type -> Q Exp) -> [FunArg] -> [Type] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (JSONClass
-> JSONFun
-> Name
-> Map Name (Name, Name, Name)
-> FunArg
-> Type
-> Q Exp
dispatchFunByType JSONClass
jc JSONFun
jf Name
conName Map Name (Name, Name, Name)
tvMap) ([FunArg] -> [FunArg]
forall a. HasCallStack => [a] -> [a]
cycle [FunArg
Omit,FunArg
Single,FunArg
Plural]) ([Type] -> [Type]
forall a. [a] -> [a]
triple [Type]
rhsArgs)

    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
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (FunArg -> JSONFun -> Arity -> Name
jsonFunValOrListName FunArg
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]
: [Q Exp]
args
            else Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ FunArg -> JSONFun -> Arity -> Name
jsonFunValOrListName FunArg
list JSONFun
jf Arity
Arity0

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

dispatchOmitField :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
dispatchOmitField :: JSONClass -> Name -> Map Name (Name, Name, Name) -> Type -> Q Exp
dispatchOmitField JSONClass
jc Name
n Map Name (Name, Name, Name)
tvMap = JSONClass
-> JSONFun
-> Name
-> Map Name (Name, Name, Name)
-> FunArg
-> Type
-> Q Exp
dispatchFunByType JSONClass
jc JSONFun
ToJSON Name
n Map Name (Name, Name, Name)
tvMap FunArg
Omit

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

dispatchOmittedField :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
dispatchOmittedField :: JSONClass -> Name -> Map Name (Name, Name, Name) -> Type -> Q Exp
dispatchOmittedField JSONClass
jc Name
n Map Name (Name, Name, Name)
tvMap = JSONClass
-> JSONFun
-> Name
-> Map Name (Name, Name, Name)
-> FunArg
-> Type
-> Q Exp
dispatchFunByType JSONClass
jc JSONFun
ParseJSON Name
n Map Name (Name, Name, Name)
tvMap FunArg
Omit

--------------------------------------------------------------------------------
-- 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Q Type
resolveTypeSynonyms [Type]
varTysOrig

    let remainingLength :: Int
        remainingLength :: Int
remainingLength = [Type] -> Int
forall a. [a] -> 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 a. Eq a => a -> [a] -> 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
                         DatatypeVariant
Language.Haskell.TH.Datatype.TypeData -> Bool
False

        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 a. a -> Q a
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 :: forall a.
JSONClass
-> Map Name (Name, Name, Name) -> [Type] -> Name -> Q a -> Q a
checkExistentialContext JSONClass
jc Map Name (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) -> [Name]
forall k a. Map k a -> [k]
M.keys Map Name (Name, Name, Name)
tvMap) [Type]
ctxt
       Bool -> Bool -> Bool
|| Map Name (Name, Name, Name) -> Int
forall k a. Map k a -> Int
M.size Map Name (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 ~> (o1, tj1, tjl1)
-- , b ~> (o2, tj2, tjl2) }
--
-- where a and b are the last two type variables of the datatype,
-- o1 and o2 are function argument of types (a -> Bool),
-- 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, Name)

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

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

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

-- | @hasKindVarChain n kind@ Checks if @kind@ is of the form
-- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or
-- kind variables.
hasKindVarChain :: Int -> Type -> Maybe [Name]
hasKindVarChain :: Int -> Type -> Maybe [Name]
hasKindVarChain Int
kindArrows Type
t =
  let uk :: NonEmpty Type
uk = Type -> NonEmpty Type
uncurryKind (Type -> Type
tyKind Type
t)
  in if (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
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 (String -> Name
forall a. HasCallStack => String -> a
error String
"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

flatten3 :: [(a,a,a)] -> [a]
flatten3 :: forall a. [(a, a, a)] -> [a]
flatten3 = ((a, a, a) -> [a] -> [a]) -> [a] -> [(a, a, a)] -> [a]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(a
a,a
b,a
c) [a]
xs -> a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:a
ba -> [a] -> [a]
forall a. a -> [a] -> [a]
:a
ca -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) []

triple :: [a] -> [a]
triple :: forall a. [a] -> [a]
triple = (a -> [a] -> [a]) -> [a] -> [a] -> [a]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x [a]
xs -> a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) []

-- | 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 b a. (b -> a -> b) -> b -> [a] -> b
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 a. a -> Q a
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
        FamilyI (OpenTypeFamilyD (TypeFamilyHead Name
_ [TyVarBndr BndrVis]
bndrs FamilyResultSig
_ Maybe InjectivityAnn
_)) [Dec]
_
          -> [TyVarBndr BndrVis] -> Q Bool
forall a. [a] -> Q Bool
withinFirstArgs [TyVarBndr BndrVis]
bndrs
        FamilyI (ClosedTypeFamilyD (TypeFamilyHead Name
_ [TyVarBndr BndrVis]
bndrs FamilyResultSig
_ Maybe InjectivityAnn
_) [TySynEqn]
_) [Dec]
_
          -> [TyVarBndr BndrVis] -> Q Bool
forall a. [a] -> Q Bool
withinFirstArgs [TyVarBndr BndrVis]
bndrs
        Info
_ -> Bool -> Q Bool
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      where
        withinFirstArgs :: [a] -> Q Bool
        withinFirstArgs :: forall a. [a] -> Q Bool
withinFirstArgs [a]
bndrs =
          let firstArgs :: [Type]
firstArgs = Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall a. [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 a. a -> Q a
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 a. Eq a => a -> [a] -> 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 :: forall a. Ord a => [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' :: forall a. Ord a => 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 a. Eq a => a -> [a] -> 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
predMentionsName :: Type -> [Name] -> Bool
predMentionsName = Type -> [Name] -> Bool
mentionsName

-- | 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 Specificity]
_ [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 Specificity]
_ [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
forall (m :: * -> *). Quote m => Lit -> m Exp
litE
                (Lit -> Q Exp)
-> (ConstructorInfo -> Lit) -> ConstructorInfo -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
stringL
                (String -> Lit)
-> (ConstructorInfo -> String) -> ConstructorInfo -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> String -> String
constructorTagModifier Options
opts
                (String -> String)
-> (ConstructorInfo -> String) -> ConstructorInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
                (Name -> String)
-> (ConstructorInfo -> Name) -> ConstructorInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorInfo -> Name
constructorName

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

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

applyCon :: Name -> Name -> Pred
applyCon :: Name -> Name -> Type
applyCon Name
con Name
t = Type -> Type -> Type
AppT (Name -> Type
ConT Name
con) (Name -> Type
VarT Name
t)

-- | 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 a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' (Name -> Type -> Type -> Type
`substNameWithKind` Type
starK) Type
t [Name]
ns

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

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

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

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

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

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

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

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

jsonFunOmitName :: JSONFun -> Arity -> Name
jsonFunOmitName :: JSONFun -> Arity -> Name
jsonFunOmitName JSONFun
ToJSON     Arity
Arity0 = 'omitField
jsonFunOmitName JSONFun
ToJSON     Arity
Arity1 = 'liftOmitField
jsonFunOmitName JSONFun
ToJSON     Arity
Arity2 = 'liftOmitField2
jsonFunOmitName JSONFun
ToEncoding Arity
Arity0 = 'omitField
jsonFunOmitName JSONFun
ToEncoding Arity
Arity1 = 'liftOmitField
jsonFunOmitName JSONFun
ToEncoding Arity
Arity2 = 'liftOmitField2
jsonFunOmitName JSONFun
ParseJSON  Arity
Arity0 = 'omittedField
jsonFunOmitName JSONFun
ParseJSON  Arity
Arity1 = 'liftOmittedField
jsonFunOmitName JSONFun
ParseJSON  Arity
Arity2 = 'liftOmittedField2

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 :: FunArg -- e.g., toJSONList if True, toJSON if False
                     -> JSONFun -> Arity -> Name
jsonFunValOrListName :: FunArg -> JSONFun -> Arity -> Name
jsonFunValOrListName FunArg
Omit   = JSONFun -> Arity -> Name
jsonFunOmitName
jsonFunValOrListName FunArg
Single = JSONFun -> Arity -> Name
jsonFunValName
jsonFunValOrListName FunArg
Plural = 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
$c== :: StarKindStatus -> StarKindStatus -> Bool
== :: StarKindStatus -> StarKindStatus -> Bool
$c/= :: StarKindStatus -> StarKindStatus -> Bool
/= :: 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