    {-# LANGUAGE CPP #-}
    {-# LANGUAGE PatternGuards #-}

    {-|
    Module:      Data.Functor.Invariant.TH
    Copyright:   (C) 2012-2017 Nicolas Frisby, (C) 2015-2017 Ryan Scott
    License:     BSD-style (see the file LICENSE)
    Maintainer:  Ryan Scott
    Portability: Template Haskell

    Functions to mechanically derive 'Data.Functor.Invariant.Invariant'
    or 'Data.Functor.Invariant.Invariant2' instances,
    or to splice 'Data.Functor.Invariant.invmap' or
    'Data.Functor.Invariant.invmap2' into Haskell source code. You need to enable
    the @TemplateHaskell@ language extension in order to use this module.
    -}
    module Data.Functor.Invariant.TH (
          -- * @deriveInvariant(2)@
          -- $deriveInvariant
          deriveInvariant
        , deriveInvariantOptions
          -- $deriveInvariant2
        , deriveInvariant2
        , deriveInvariant2Options
          -- * @makeInvmap(2)@
          -- $make
        , makeInvmap
        , makeInvmapOptions
        , makeInvmap2
        , makeInvmap2Options
          -- * 'Options'
        , Options(..)
        , defaultOptions
        ) where

    import           Control.Monad (unless, when)

    import           Data.Functor.Invariant.TH.Internal
    import qualified Data.List as List
    import qualified Data.Map as Map ((!), fromList, keys, lookup, member, size)
    import           Data.Maybe

    import           Language.Haskell.TH.Datatype as Datatype
    import           Language.Haskell.TH.Datatype.TyVarBndr
    import           Language.Haskell.TH.Lib
    import           Language.Haskell.TH.Ppr
    import           Language.Haskell.TH.Syntax

    -------------------------------------------------------------------------------
    -- User-facing API
    -------------------------------------------------------------------------------

    -- | Options that further configure how the functions in
    -- "Data.Functor.Invariant.TH" should behave.
    newtype Options = Options
      { Options -> Bool
    emptyCaseBehavior :: Bool
        -- ^ If 'True', derived instances for empty data types (i.e., ones with
        --   no data constructors) will use the @EmptyCase@ language extension.
        --   If 'False', derived instances will simply use 'seq' instead.
        --   (This has no effect on GHCs before 7.8, since @EmptyCase@ is only
        --   available in 7.8 or later.)
      } deriving (Options -> Options -> Bool
    (Options -> Options -> Bool)
    -> (Options -> Options -> Bool) -> Eq Options
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Options -> Options -> Bool
    == :: Options -> Options -> Bool
    $c/= :: Options -> Options -> Bool
    /= :: Options -> Options -> Bool
    Eq, Eq Options
    Eq Options =>
    (Options -> Options -> Ordering)
    -> (Options -> Options -> Bool)
    -> (Options -> Options -> Bool)
    -> (Options -> Options -> Bool)
    -> (Options -> Options -> Bool)
    -> (Options -> Options -> Options)
    -> (Options -> Options -> Options)
    -> Ord Options
    Options -> Options -> Bool
    Options -> Options -> Ordering
    Options -> Options -> Options
    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 :: Options -> Options -> Ordering
    compare :: Options -> Options -> Ordering
    $c< :: Options -> Options -> Bool
    < :: Options -> Options -> Bool
    $c<= :: Options -> Options -> Bool
    <= :: Options -> Options -> Bool
    $c> :: Options -> Options -> Bool
    > :: Options -> Options -> Bool
    $c>= :: Options -> Options -> Bool
    >= :: Options -> Options -> Bool
    $cmax :: Options -> Options -> Options
    max :: Options -> Options -> Options
    $cmin :: Options -> Options -> Options
    min :: Options -> Options -> Options
    Ord, ReadPrec [Options]
    ReadPrec Options
    Int -> ReadS Options
    ReadS [Options]
    (Int -> ReadS Options)
    -> ReadS [Options]
    -> ReadPrec Options
    -> ReadPrec [Options]
    -> Read Options
    forall a.
    (Int -> ReadS a)
    -> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
    $creadsPrec :: Int -> ReadS Options
    readsPrec :: Int -> ReadS Options
    $creadList :: ReadS [Options]
    readList :: ReadS [Options]
    $creadPrec :: ReadPrec Options
    readPrec :: ReadPrec Options
    $creadListPrec :: ReadPrec [Options]
    readListPrec :: ReadPrec [Options]
    Read, Int -> Options -> ShowS
    [Options] -> ShowS
    Options -> String
    (Int -> Options -> ShowS)
    -> (Options -> String) -> ([Options] -> ShowS) -> Show Options
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Options -> ShowS
    showsPrec :: Int -> Options -> ShowS
    $cshow :: Options -> String
    show :: Options -> String
    $cshowList :: [Options] -> ShowS
    showList :: [Options] -> ShowS
    Show)

    -- | Conservative 'Options' that doesn't attempt to use @EmptyCase@ (to
    -- prevent users from having to enable that extension at use sites.)
    defaultOptions :: Options
    defaultOptions :: Options
    defaultOptions = Options { emptyCaseBehavior :: Bool
    emptyCaseBehavior = Bool
    False }

    {- $deriveInvariant

    'deriveInvariant' automatically generates an 'Data.Functor.Invariant.Invariant'
    instance declaration for a data type, newtype, or data family instance that has
    at least one type variable.  This emulates what would (hypothetically) happen
    if you could attach a @deriving 'Data.Functor.Invariant.Invariant'@ clause to
    the end of a data declaration. Examples:

    @
    &#123;-&#35; LANGUAGE TemplateHaskell &#35;-&#125;
    import Data.Functor.Invariant.TH

    data Pair a = Pair a a
    $('deriveInvariant' ''Pair) -- instance Invariant Pair where ...

    newtype Alt f a = Alt (f a)
    $('deriveInvariant' ''Alt) -- instance Invariant f => Invariant (Alt f) where ...
    @

    If you are using @template-haskell-2.7.0.0@ or later (i.e., GHC 7.4 or later),
    'deriveInvariant' can also be used to derive 'Data.Functor.Invariant.Invariant' instances for data family
    instances (which requires the @-XTypeFamilies@ extension). To do so, pass the name of
    a data or newtype instance constructor to 'deriveInvariant'.  Note that the generated
    code may require the @-XFlexibleInstances@ extension. Some examples:

    @
    &#123;-&#35; LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies &#35;-&#125;
    import Data.Functor.Invariant.TH

    class AssocClass a b where
        data AssocData a b
    instance AssocClass Int b where
        data AssocData Int b = AssocDataInt1 Int | AssocDataInt2 b Int
    $('deriveInvariant' 'AssocDataInt1) -- instance Invariant (AssocData Int) where ...
    -- Alternatively, one could use $(deriveInvariant 'AssocDataInt2)

    data family DataFam a b
    newtype instance DataFam () b = DataFamB b
    $('deriveInvariant' 'DataFamB) -- instance Invariant (DataFam ())
    @

    Note that there are some limitations:

    * The 'Name' argument to 'deriveInvariant' must not be a type synonym.

    * With 'deriveInvariant', the argument's last type variable must be of kind @*@.
      For other ones, type variables of kind @* -> *@ are assumed to require an
      'Data.Functor.Invariant.Invariant' context. For more complicated scenarios,
      use 'makeInvmap'.

    * If using the @-XDatatypeContexts@, @-XExistentialQuantification@, or @-XGADTs@
      extensions, a constraint cannot mention the last type variable. For example,
      @data Illegal a where I :: Ord a => a -> Illegal a@ cannot have a derived
      'Data.Functor.Invariant.Invariant' instance.

    * If the last type variable is used within a data field of a constructor, it must only
      be used in the last argument of the data type constructor. For example, @data Legal a
      = Legal (Either Int a)@ can have a derived 'Data.Functor.Invariant.Invariant' instance,
      but @data Illegal a = Illegal (Either a a)@ cannot.

    * Data family instances must be able to eta-reduce the last type variable. In other
      words, if you have a instance of the form:

      @
      data family Family a1 ... an t
      data instance Family e1 ... e2 v = ...
      @

      Then the following conditions must hold:

      1. @v@ must be a type variable.
      2. @v@ must not be mentioned in any of @e1@, ..., @e2@.

    -}

    -- | Generates an 'Data.Functor.Invariant.Invariant' instance declaration for the given
    -- data type or data family instance.
    deriveInvariant :: Name -> Q [Dec]
    deriveInvariant :: Name -> Q [Dec]
    deriveInvariant = Options -> Name -> Q [Dec]
    deriveInvariantOptions Options
    defaultOptions

    -- | Like 'deriveInvariant', but takes an 'Options' argument.
    deriveInvariantOptions :: Options -> Name -> Q [Dec]
    deriveInvariantOptions :: Options -> Name -> Q [Dec]
    deriveInvariantOptions = InvariantClass -> Options -> Name -> Q [Dec]
    deriveInvariantClass InvariantClass
    Invariant

    {- $deriveInvariant2

    'deriveInvariant2' automatically generates an
    'Data.Functor.Invariant.Invariant2' instance declaration for a data type,
    newtype, or data family instance that has at least two type variables.  This
    emulates what would (hypothetically) happen if you could attach a @deriving
    'Data.Functor.Invariant.Invariant2'@ clause to the end of a data declaration.
    Examples:

    @
    &#123;-&#35; LANGUAGE TemplateHaskell &#35;-&#125;
    import Data.Functor.Invariant.TH

    data OneOrNone a b = OneL a | OneR b | None
    $('deriveInvariant2' ''OneOrNone) -- instance Invariant2 OneOrNone where ...

    newtype Alt2 f a b = Alt2 (f a b)
    $('deriveInvariant2' ''Alt2) -- instance Invariant2 f => Invariant2 (Alt2 f) where ...
    @

    The same restrictions that apply to 'deriveInvariant' also apply to 'deriveInvariant2',
    with some caveats:

    * With 'deriveInvariant2', the last type variables must both be of kind @*@. For other
      ones, type variables of kind @* -> *@ are assumed to require an 'Data.Functor.Invariant.Invariant'
      constraint, and type variables of kind @* -> * -> *@ are assumed to require an
      'Data.Functor.Invariant.Invariant2' constraint. For more complicated scenarios, use 'makeInvmap2'.

    * If using the @-XDatatypeContexts@, @-XExistentialQuantification@, or @-XGADTs@
      extensions, a constraint cannot mention either of the last two type variables. For
      example, @data Illegal2 a b where I2 :: Ord a => a -> b -> Illegal2 a b@ cannot
      have a derived 'Data.Functor.Invariant.Invariant2' instance.

    * If either of the last two type variables is used within a data field of a constructor,
      it must only be used in the last two arguments of the data type constructor. For
      example, @data Legal a b = Legal (Int, Int, a, b)@ can have a derived
      'Data.Functor.Invariant.Invariant2' instance, but
      @data Illegal a b = Illegal (a, b, a, b)@ cannot.

    * Data family instances must be able to eta-reduce the last two type variables. In other
      words, if you have a instance of the form:

      @
      data family Family a1 ... an t1 t2
      data instance Family e1 ... e2 v1 v2 = ...
      @

      Then the following conditions must hold:

      1. @v1@ and @v2@ must be distinct type variables.
      2. Neither @v1@ not @v2@ must be mentioned in any of @e1@, ..., @e2@.

    -}

    -- | Generates an 'Data.Functor.Invariant.Invariant2' instance declaration for
    -- the given data type or data family instance.
    deriveInvariant2 :: Name -> Q [Dec]
    deriveInvariant2 :: Name -> Q [Dec]
    deriveInvariant2 = Options -> Name -> Q [Dec]
    deriveInvariant2Options Options
    defaultOptions

    -- | Like 'deriveInvariant2', but takes an 'Options' argument.
    deriveInvariant2Options :: Options -> Name -> Q [Dec]
    deriveInvariant2Options :: Options -> Name -> Q [Dec]
    deriveInvariant2Options = InvariantClass -> Options -> Name -> Q [Dec]
    deriveInvariantClass InvariantClass
    Invariant2

    {- $make

    There may be scenarios in which you want to @invmap@ over an arbitrary data
    type or data family instance without having to make the type an instance of
    'Data.Functor.Invariant.Invariant'. For these cases, this module provides
    several functions (all prefixed with @make-@) that splice the appropriate
    lambda expression into your source code. Example:

    This is particularly useful for creating instances for sophisticated data
    types. For example, 'deriveInvariant' cannot infer the correct type context for
    @newtype HigherKinded f a b c = HigherKinded (f a b c)@, since @f@ is of kind
    @* -> * -> * -> *@. However, it is still possible to create an
    'Data.Functor.Invariant.Invariant' instance for @HigherKinded@ without too much
    trouble using 'makeInvmap':

    @
    &#123;-&#35; LANGUAGE FlexibleContexts, TemplateHaskell &#35;-&#125;
    import Data.Functor.Invariant
    import Data.Functor.Invariant.TH

    newtype HigherKinded f a b c = HigherKinded (f a b c)

    instance Invariant (f a b) => Invariant (HigherKinded f a b) where
        invmap = $(makeInvmap ''HigherKinded)
    @

    -}

    -- | Generates a lambda expression which behaves like
    -- 'Data.Functor.Invariant.invmap' (without requiring an
    -- 'Data.Functor.Invariant.Invariant' instance).
    makeInvmap :: Name -> Q Exp
    makeInvmap :: Name -> Q Exp
    makeInvmap = Options -> Name -> Q Exp
    makeInvmapOptions Options
    defaultOptions

    -- | Like 'makeInvmap', but takes an 'Options' argument.
    makeInvmapOptions :: Options -> Name -> Q Exp
    makeInvmapOptions :: Options -> Name -> Q Exp
    makeInvmapOptions = InvariantClass -> Options -> Name -> Q Exp
    makeInvmapClass InvariantClass
    Invariant

    -- | Generates a lambda expression which behaves like
    -- 'Data.Functor.Invariant.invmap2' (without requiring an
    -- 'Data.Functor.Invariant.Invariant2' instance).
    makeInvmap2 :: Name -> Q Exp
    makeInvmap2 :: Name -> Q Exp
    makeInvmap2 = Options -> Name -> Q Exp
    makeInvmap2Options Options
    defaultOptions

    -- | Like 'makeInvmap2', but takes an 'Options' argument.
    makeInvmap2Options :: Options -> Name -> Q Exp
    makeInvmap2Options :: Options -> Name -> Q Exp
    makeInvmap2Options = InvariantClass -> Options -> Name -> Q Exp
    makeInvmapClass InvariantClass
    Invariant2

    -------------------------------------------------------------------------------
    -- Code generation
    -------------------------------------------------------------------------------

    -- | Derive an Invariant(2) instance declaration (depending on the InvariantClass
    -- argument's value).
    deriveInvariantClass :: InvariantClass -> Options -> Name -> Q [Dec]
    deriveInvariantClass :: InvariantClass -> Options -> Name -> Q [Dec]
    deriveInvariantClass InvariantClass
    iClass Options
    opts Name
    name = do
      info <- Name -> Q DatatypeInfo
    reifyDatatype Name
    name
      case 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
          (instanceCxt, instanceType)
            <- InvariantClass
    -> Name -> [Type] -> [Type] -> DatatypeVariant -> Q ([Type], Type)
    buildTypeInstance InvariantClass
    iClass Name
    parentName [Type]
    ctxt [Type]
    instTys DatatypeVariant
    variant
          (:[]) `fmap` instanceD (return instanceCxt)
                                 (return instanceType)
                                 (invmapDecs iClass opts parentName instTys cons)

    -- | Generates a declaration defining the primary function corresponding to a
    -- particular class (invmap for Invariant and invmap2 for Invariant2).
    invmapDecs :: InvariantClass -> Options -> Name -> [Type] -> [ConstructorInfo]
               -> [Q Dec]
    invmapDecs :: InvariantClass
    -> Options -> Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
    invmapDecs InvariantClass
    iClass Options
    opts Name
    parentName [Type]
    instTys [ConstructorInfo]
    cons =
        [ Name -> [Q Clause] -> Q Dec
    forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
    funD (InvariantClass -> Name
    invmapName InvariantClass
    iClass)
               [ [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
    $ InvariantClass
    -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp
    makeInvmapForCons InvariantClass
    iClass Options
    opts Name
    parentName [Type]
    instTys [ConstructorInfo]
    cons)
                        []
               ]
        ]

    -- | Generates a lambda expression which behaves like invmap (for Invariant),
    -- or invmap2 (for Invariant2).
    makeInvmapClass :: InvariantClass -> Options -> Name -> Q Exp
    makeInvmapClass :: InvariantClass -> Options -> Name -> Q Exp
    makeInvmapClass InvariantClass
    iClass Options
    opts Name
    name = do
      info <- Name -> Q DatatypeInfo
    reifyDatatype Name
    name
      case 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
                     } ->
          -- We force buildTypeInstance here since it performs some checks for whether
          -- or not the provided datatype can actually have invmap/invmap2
          -- implemented for it, and produces errors if it can't.
          InvariantClass
    -> Name -> [Type] -> [Type] -> DatatypeVariant -> Q ([Type], Type)
    buildTypeInstance InvariantClass
    iClass Name
    parentName [Type]
    ctxt [Type]
    instTys DatatypeVariant
    variant
            Q ([Type], Type) -> Q Exp -> Q Exp
    forall a b. Q a -> Q b -> Q b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> InvariantClass
    -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp
    makeInvmapForCons InvariantClass
    iClass Options
    opts Name
    parentName [Type]
    instTys [ConstructorInfo]
    cons

    -- | Generates a lambda expression for invmap(2) for the given constructors.
    -- All constructors must be from the same type.
    makeInvmapForCons :: InvariantClass -> Options -> Name -> [Type] -> [ConstructorInfo]
                      -> Q Exp
    makeInvmapForCons :: InvariantClass
    -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp
    makeInvmapForCons InvariantClass
    iClass Options
    opts Name
    _parentName [Type]
    instTys [ConstructorInfo]
    cons = do
        value      <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "value"
        covMaps    <- newNameList "covMap" numNbs
        contraMaps <- newNameList "contraMap" numNbs

        let mapFuns    = [Name] -> [Name] -> [(Name, Name)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Name]
    covMaps [Name]
    contraMaps
            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
    - Int
    numNbs) [Type]
    instTys
            tvMap      = [(Name, (Name, Name))] -> Map Name (Name, Name)
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList ([(Name, (Name, Name))] -> Map Name (Name, Name))
    -> [(Name, (Name, Name))] -> Map Name (Name, Name)
    forall a b. (a -> b) -> a -> b
    $ [Name] -> [(Name, Name)] -> [(Name, (Name, Name))]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Name]
    lastTyVars [(Name, Name)]
    mapFuns
            argNames   = [[Name]] -> [Name]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ([[Name]] -> [[Name]]
    forall a. [[a]] -> [[a]]
    List.transpose [[Name]
    covMaps, [Name]
    contraMaps]) [Name] -> [Name] -> [Name]
    forall a. [a] -> [a] -> [a]
    ++ [Name
    value]
        lamE (map varP argNames)
            . appsE
            $ [ varE $ invmapConstName iClass
              , makeFun value tvMap
              ] ++ map varE argNames
      where
        numNbs :: Int
        numNbs :: Int
    numNbs = InvariantClass -> Int
    forall a. Enum a => a -> Int
    fromEnum InvariantClass
    iClass

        makeFun :: Name -> TyVarMap -> Q Exp
        makeFun :: Name -> Map Name (Name, Name) -> Q Exp
    makeFun Name
    value Map Name (Name, Name)
    tvMap = do
          roles <- Name -> Q [Role]
    reifyRoles Name
    _parentName
          let rroles = [Role]
    roles
          case () of
            ()
    _ | ([Role] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Role]
    rroles Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    numNbs) Bool -> Bool -> Bool
    &&
                ((Role -> Bool) -> [Role] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (Role -> Role -> Bool
    forall a. Eq a => a -> a -> Bool
    == Role
    PhantomR) (Int -> [Role] -> [Role]
    forall a. Int -> [a] -> [a]
    drop ([Role] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Role]
    rroles Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    numNbs) [Role]
    rroles))
             -> Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    coerceValName 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
    value

              | [ConstructorInfo] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [ConstructorInfo]
    cons Bool -> Bool -> Bool
    && Options -> Bool
    emptyCaseBehavior Options
    opts
             -> 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) []

              | [ConstructorInfo] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [ConstructorInfo]
    cons
             -> 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
    seqValName) (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    value) Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE`
                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
    errorValName)
                     (String -> Q Exp
    forall (m :: * -> *). Quote m => String -> m Exp
    stringE (String -> Q Exp) -> String -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ String
    "Void " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Name -> String
    nameBase (InvariantClass -> Name
    invmapName InvariantClass
    iClass))

              | 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)
                      ((ConstructorInfo -> Q Match) -> [ConstructorInfo] -> [Q Match]
    forall a b. (a -> b) -> [a] -> [b]
    map (InvariantClass
    -> Map Name (Name, Name) -> ConstructorInfo -> Q Match
    makeInvmapForCon InvariantClass
    iClass Map Name (Name, Name)
    tvMap) [ConstructorInfo]
    cons)

    -- | Generates a match for invmap(2) for a single constructor.
    makeInvmapForCon :: InvariantClass -> TyVarMap -> ConstructorInfo -> Q Match
    makeInvmapForCon :: InvariantClass
    -> Map Name (Name, Name) -> ConstructorInfo -> Q Match
    makeInvmapForCon InvariantClass
    iClass Map Name (Name, Name)
    tvMap
      con :: ConstructorInfo
    con@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
    constructorName    = Name
    conName
                           , constructorContext :: ConstructorInfo -> [Type]
    constructorContext = [Type]
    ctxt }) = do
        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` Map Name (Name, Name) -> [Name]
    forall k a. Map k a -> [k]
    Map.keys Map Name (Name, Name)
    tvMap) [Type]
    ctxt
                Bool -> Bool -> Bool
    || Map Name (Name, Name) -> Int
    forall k a. Map k a -> Int
    Map.size Map Name (Name, Name)
    tvMap Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < InvariantClass -> Int
    forall a. Enum a => a -> Int
    fromEnum InvariantClass
    iClass) (Q () -> Q ()) -> Q () -> Q ()
    forall a b. (a -> b) -> a -> b
    $
          Name -> Q ()
    forall a. Name -> Q a
    existentialContextError Name
    conName
        parts <- InvariantClass
    -> Map Name (Name, Name)
    -> FFoldType (Exp -> Q Exp)
    -> ConstructorInfo
    -> Q [Exp -> Q Exp]
    forall a.
    InvariantClass
    -> Map Name (Name, Name) -> FFoldType a -> ConstructorInfo -> Q [a]
    foldDataConArgs InvariantClass
    iClass Map Name (Name, Name)
    tvMap FFoldType (Exp -> Q Exp)
    ft_invmap ConstructorInfo
    con
        match_for_con conName parts
      where
        ft_invmap :: FFoldType (Exp -> Q Exp)
        ft_invmap :: FFoldType (Exp -> Q Exp)
    ft_invmap = FT { ft_triv :: Exp -> Q Exp
    ft_triv   = Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return
                       , ft_var :: Name -> Exp -> Q Exp
    ft_var    = \Name
    v Exp
    x -> Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    VarE ((Name, Name) -> Name
    forall a b. (a, b) -> a
    fst (Map Name (Name, Name)
    tvMap Map Name (Name, Name) -> Name -> (Name, Name)
    forall k a. Ord k => Map k a -> k -> a
    Map.! Name
    v)) Exp -> Exp -> Exp
    `AppE` Exp
    x
                       , ft_co_var :: Name -> Exp -> Q Exp
    ft_co_var = \Name
    v Exp
    x -> Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    VarE ((Name, Name) -> Name
    forall a b. (a, b) -> b
    snd (Map Name (Name, Name)
    tvMap Map Name (Name, Name) -> Name -> (Name, Name)
    forall k a. Ord k => Map k a -> k -> a
    Map.! Name
    v)) Exp -> Exp -> Exp
    `AppE` Exp
    x
                       , ft_fun :: (Exp -> Q Exp) -> (Exp -> Q Exp) -> Exp -> Q Exp
    ft_fun    = \Exp -> Q Exp
    g Exp -> Q Exp
    h Exp
    x -> (Exp -> Q Exp) -> Q Exp
    mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ \Exp
    b -> do
                           gg <- Exp -> Q Exp
    g Exp
    b
                           h $ x `AppE` gg
                       , ft_tup :: TupleSort -> [Exp -> Q Exp] -> Exp -> Q Exp
    ft_tup    = (Name -> [Exp -> Q Exp] -> Q Match)
    -> TupleSort -> [Exp -> Q Exp] -> Exp -> Q Exp
    forall a.
    (Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
    mkSimpleTupleCase Name -> [Exp -> Q Exp] -> Q Match
    match_for_con
                       , ft_ty_app :: Bool -> [(Type, Exp -> Q Exp, Exp -> Q Exp)] -> Exp -> Q Exp
    ft_ty_app = \Bool
    contravariant [(Type, Exp -> Q Exp, Exp -> Q Exp)]
    argGs Exp
    x -> do
                           let inspect :: (Type, Exp -> Q Exp, Exp -> Q Exp) -> [Q Exp]
                               inspect :: (Type, Exp -> Q Exp, Exp -> Q Exp) -> [Q Exp]
    inspect (Type
    argTy, Exp -> Q Exp
    g, Exp -> Q Exp
    h)
                                 -- If the argument type is a bare occurrence of one
                                 -- of the data type's last type variables, then we
                                 -- can generate more efficient code.
                                 -- This was inspired by GHC#17880.
                                 | Just Name
    argVar <- Type -> Maybe Name
    varTToName_maybe Type
    argTy
                                 , Just (Name
    covMap, Name
    contraMap) <- Name -> Map Name (Name, Name) -> Maybe (Name, Name)
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup Name
    argVar Map Name (Name, Name)
    tvMap
                                 = (Name -> Q Exp) -> [Name] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map (Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> (Name -> Exp) -> Name -> Q Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> Exp
    VarE) ([Name] -> [Q Exp]) -> [Name] -> [Q Exp]
    forall a b. (a -> b) -> a -> b
    $
                                   if Bool
    contravariant
                                      then [Name
    contraMap, Name
    covMap]
                                      else [Name
    covMap, Name
    contraMap]
                                 | Bool
    otherwise
                                 = [(Exp -> Q Exp) -> Q Exp
    mkSimpleLam Exp -> Q Exp
    g, (Exp -> Q Exp) -> Q Exp
    mkSimpleLam Exp -> Q Exp
    h]
                           [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 (InvariantClass -> Name
    invmapName (Int -> InvariantClass
    forall a. Enum a => Int -> a
    toEnum ([(Type, Exp -> Q Exp, Exp -> Q Exp)] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(Type, Exp -> Q Exp, Exp -> Q Exp)]
    argGs)))
                                 Q Exp -> [Q Exp] -> [Q Exp]
    forall a. a -> [a] -> [a]
    : ((Type, Exp -> Q Exp, Exp -> Q Exp) -> [Q Exp])
    -> [(Type, Exp -> Q Exp, Exp -> Q Exp)] -> [Q Exp]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (Type, Exp -> Q Exp, Exp -> Q Exp) -> [Q Exp]
    inspect [(Type, Exp -> Q Exp, Exp -> Q Exp)]
    argGs
                                [Q Exp] -> [Q Exp] -> [Q Exp]
    forall a. [a] -> [a] -> [a]
    ++ [Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Exp
    x]
                       , ft_forall :: [TyVarBndrSpec] -> (Exp -> Q Exp) -> Exp -> Q Exp
    ft_forall  = \[TyVarBndrSpec]
    _ Exp -> Q Exp
    g Exp
    x -> Exp -> Q Exp
    g Exp
    x
                       , ft_bad_app :: Exp -> Q Exp
    ft_bad_app = \Exp
    _ -> Name -> Q Exp
    forall a. Name -> Q a
    outOfPlaceTyVarError Name
    conName
                       }

        -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
        match_for_con :: Name -> [Exp -> Q Exp] -> Q Match
        match_for_con :: Name -> [Exp -> Q Exp] -> Q Match
    match_for_con = (Name -> [Q Exp] -> Q Exp) -> Name -> [Exp -> Q Exp] -> Q Match
    forall a. (Name -> [a] -> Q Exp) -> Name -> [Exp -> a] -> Q Match
    mkSimpleConMatch ((Name -> [Q Exp] -> Q Exp) -> Name -> [Exp -> Q Exp] -> Q Match)
    -> (Name -> [Q Exp] -> Q Exp) -> Name -> [Exp -> Q Exp] -> Q Match
    forall a b. (a -> b) -> a -> b
    $ \Name
    conName' [Q Exp]
    xs ->
           [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    appsE (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    conE Name
    conName'Q Exp -> [Q Exp] -> [Q Exp]
    forall a. a -> [a] -> [a]
    :[Q Exp]
    xs) -- Con x1 x2 ..

    -------------------------------------------------------------------------------
    -- Template Haskell reifying and AST manipulation
    -------------------------------------------------------------------------------

    -- For the given Types, generate an instance context and head. Coming up with
    -- the instance type isn't as simple as dropping the last types, as you need to
    -- be wary of kinds being instantiated with *.
    -- See Note [Type inference in derived instances]
    buildTypeInstance :: InvariantClass
                      -- ^ Invariant or Invariant2
                      -> Name
                      -- ^ The type constructor or data family name
                      -> 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 :: InvariantClass
    -> Name -> [Type] -> [Type] -> DatatypeVariant -> Q ([Type], Type)
    buildTypeInstance InvariantClass
    iClass Name
    tyConName [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.)
        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 = [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
    - InvariantClass -> Int
    forall a. Enum a => a -> Int
    fromEnum InvariantClass
    iClass

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

            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.
        when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $
          derivingKindError iClass tyConName

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

            -- Substitute kind * for any dropped kind variables
            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]
            (remainingTysExpSubst, droppedTysExpSubst) =
              splitAt remainingLength varTysExpSubst

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

        -- If any of the dropped types were polykinded, ensure that there are of kind *
        -- after substituting * for the dropped kind variables. If not, throw an error.
        unless (all hasKindStar droppedTysExpSubst) $
          derivingKindError iClass tyConName

        let preds    :: [Maybe Pred]
            kvNames  :: [[Name]]
            kvNames' :: [Name]
            -- Derive instance constraints (and any kind variables which are specialized
            -- to * in those constraints)
            (preds, kvNames) = unzip $ map (deriveConstraint iClass) remainingTysExpSubst
            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 -> 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 -> Type) -> [Type] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map ([Name] -> Type -> Type
    substNamesWithKindStar ([Name] -> [Name] -> [Name]
    forall a. Eq a => [a] -> [a] -> [a]
    List.union [Name]
    droppedKindVarNames [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 <-
          case variant of
            DatatypeVariant
    Datatype          -> Bool -> Q Bool
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
            DatatypeVariant
    Newtype           -> Bool -> Q Bool
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
            DatatypeVariant
    DataInstance      -> Bool -> Q Bool
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True
            DatatypeVariant
    NewtypeInstance   -> Bool -> Q Bool
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True
            DatatypeVariant
    Datatype.TypeData -> Name -> Q Bool
    forall a. Name -> Q a
    typeDataError Name
    tyConName

        let remainingTysOrigSubst' :: [Type]
            -- See Note [Kind signatures in derived instances] for an explanation
            -- of the isDataFamily check.
            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 = [Maybe Type] -> [Type]
    forall a. [Maybe a] -> [a]
    catMaybes [Maybe Type]
    preds

            instanceType :: Type
            instanceType = Type -> Type -> Type
    AppT (Name -> Type
    ConT (Name -> Type) -> Name -> Type
    forall a b. (a -> b) -> a -> b
    $ InvariantClass -> Name
    invariantClassName InvariantClass
    iClass)
                         (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.
        when (any (`predMentionsName` droppedTyVarNames) dataCxt) $
          datatypeContextError tyConName instanceType
        -- Also ensure the dropped types can be safely eta-reduced. Otherwise,
        -- throw an error.
        unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $
          etaReductionError instanceType
        return (instanceCxt, 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 :: InvariantClass -> Type -> (Maybe Pred, [Name])
    deriveConstraint :: InvariantClass -> Type -> (Maybe Type, [Name])
    deriveConstraint InvariantClass
    iClass Type
    t
      | Bool -> Bool
    not (Type -> Bool
    isTyVar Type
    t) = (Maybe Type
    forall a. Maybe a
    Nothing, [])
      | Bool
    otherwise = case Int -> Type -> Maybe [Name]
    hasKindVarChain Int
    1 Type
    t of
          Just [Name]
    ns | InvariantClass
    iClass InvariantClass -> InvariantClass -> Bool
    forall a. Ord a => a -> a -> Bool
    >= InvariantClass
    Invariant
                  -> (Type -> Maybe Type
    forall a. a -> Maybe a
    Just (Name -> Name -> Type
    applyClass Name
    invariantTypeName Name
    tName), [Name]
    ns)
          Maybe [Name]
    _ -> case Int -> Type -> Maybe [Name]
    hasKindVarChain Int
    2 Type
    t of
                    Just [Name]
    ns | InvariantClass
    iClass InvariantClass -> InvariantClass -> Bool
    forall a. Eq a => a -> a -> Bool
    == InvariantClass
    Invariant2
                            -> (Type -> Maybe Type
    forall a. a -> Maybe a
    Just (Name -> Name -> Type
    applyClass Name
    invariant2TypeName Name
    tName), [Name]
    ns)
                    Maybe [Name]
    _       -> (Maybe Type
    forall a. Maybe a
    Nothing, [])
      where
        tName :: Name
        tName :: Name
    tName = Type -> Name
    varTToName Type
    t

    {-
    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 our type inferencer is pretty
    unsophisticated - see Note [Type inference in derived instances]), 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 make- 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) (c :: 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 k1 -> k2 (where k1/k2 are * or kind
            variables), then generate an Invariant 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 :: k3 -> *) (g :: k1 -> k2 -> k3) (a :: k1) (b :: k2)
                = Compose (f (g a b))

            Which would have a derived Invariant2 instance of:

              instance (Invariant f, Invariant2 g) => Invariant2 (Compose f g) where ...

       (ii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are
            * or kind variables), then generate a Invariant2 n constraint and perform
            kind substitution as in the other case.
    -}

    -------------------------------------------------------------------------------
    -- 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 :: InvariantClass -> Name -> Q a
    derivingKindError :: forall a. InvariantClass -> Name -> Q a
    derivingKindError InvariantClass
    iClass Name
    tyConName = String -> Q a
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail
        (String -> Q a) -> ShowS -> String -> Q a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "Cannot derive well-kinded instance of form ‘"
        ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    className
        ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> ShowS
    showChar Char
    ' '
        ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Bool -> ShowS -> ShowS
    showParen Bool
    True
          ( String -> ShowS
    showString (Name -> String
    nameBase Name
    tyConName)
          ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    " ..."
          )
        ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "‘\n\tClass "
        ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    className
        ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    " expects an argument of kind "
        ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    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
    $ InvariantClass -> Int
    forall a. Enum a => a -> Int
    fromEnum InvariantClass
    iClass)
        (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
    $ InvariantClass -> Name
    invariantClassName InvariantClass
    iClass

    -- | 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) -> ShowS -> String -> Q a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "Can't make a derived instance of ‘"
        ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString (Type -> String
    forall a. Ppr a => a -> String
    pprint Type
    instanceType)
        ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "‘:\n\tData type ‘"
        ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString (Name -> String
    nameBase Name
    dataName)
        ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    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 has an existential constraint which mentions one of the
    -- eta-reduced type variables.
    existentialContextError :: Name -> Q a
    existentialContextError :: forall a. Name -> Q a
    existentialContextError Name
    conName = String -> Q a
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail
        (String -> Q a) -> ShowS -> String -> Q a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "Constructor ‘"
        ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString (Name -> String
    nameBase Name
    conName)
        ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "‘ must be truly polymorphic in the last argument(s) of the data type"
        (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 :: Name -> Q a
    outOfPlaceTyVarError :: forall a. Name -> Q a
    outOfPlaceTyVarError Name
    conName = String -> Q a
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail
      (String -> Q a) -> ShowS -> String -> Q a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "Constructor ‘"
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString (Name -> String
    nameBase Name
    conName)
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "‘ must only use its last two type variable(s) within"
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    " the last two argument(s) of a data type"
      (String -> Q a) -> String -> Q a
    forall a b. (a -> b) -> a -> b
    $ String
    ""

    -- | 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 -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    forall a. Ppr a => a -> String
    pprint Type
    instanceType

    -- | We cannot implement class methods at the term level for @type data@
    -- declarations, which only exist at the type level.
    typeDataError :: Name -> Q a
    typeDataError :: forall a. Name -> Q a
    typeDataError Name
    dataName = String -> Q a
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail
      (String -> Q a) -> ShowS -> String -> Q a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "Cannot derive instance for ‘"
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString (Name -> String
    nameBase Name
    dataName)
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "‘, which is a ‘type data‘ declaration"
      (String -> Q a) -> String -> Q a
    forall a b. (a -> b) -> a -> b
    $ String
    ""

    -------------------------------------------------------------------------------
    -- Generic traversal for functor-like deriving
    -------------------------------------------------------------------------------

    -- Much of the code below is cargo-culted from the TcGenFunctor module in GHC.

    data FFoldType a      -- Describes how to fold over a Type in a functor like way
       = FT { forall a. FFoldType a -> a
    ft_triv    :: a
              -- ^ Does not contain variables
            , forall a. FFoldType a -> Name -> a
    ft_var     :: Name -> a
              -- ^ A bare variable
            , forall a. FFoldType a -> Name -> a
    ft_co_var  :: Name -> a
              -- ^ A bare variable, contravariantly
            , forall a. FFoldType a -> a -> a -> a
    ft_fun     :: a -> a -> a
              -- ^ Function type
            , forall a. FFoldType a -> TupleSort -> [a] -> a
    ft_tup     :: TupleSort -> [a] -> a
              -- ^ Tuple type. The [a] is the result of folding over the
              --   arguments of the tuple.
            , forall a. FFoldType a -> Bool -> [(Type, a, a)] -> a
    ft_ty_app  :: Bool -> [(Type, a, a)] -> a
              -- ^ Type app, variables only in last argument. The [(Type, a, a)]
              --   represents the last argument types. That is, they form the
              --   argument parts of @fun_ty arg_ty_1 ... arg_ty_n@.
              --
              --   The Bool is True if the Type is in a surrounding context that is
              --   contravariant, and False if the surrounding context is covariant.
              --   The two @a@ fields in [(Type, a, a)] represent the results of
              --   folding over the Type in a covariant and contravariant manner,
              --   respectively.
            , forall a. FFoldType a -> a
    ft_bad_app :: a
              -- ^ Type app, variable other than in last arguments
            , forall a. FFoldType a -> [TyVarBndrSpec] -> a -> a
    ft_forall  :: [TyVarBndrSpec] -> a -> a
              -- ^ Forall type
         }

    -- Note that in GHC, this function is pure. It must be monadic here since we:
    --
    -- (1) Expand type synonyms
    -- (2) Detect type family applications
    --
    -- Which require reification in Template Haskell, but are pure in Core.
    functorLikeTraverse :: InvariantClass -- ^ Invariant or Invariant2
                        -> TyVarMap       -- ^ Variables to look for
                        -> FFoldType a    -- ^ How to fold
                        -> Type           -- ^ Type to process
                        -> Q a
    functorLikeTraverse :: forall a.
    InvariantClass
    -> Map Name (Name, Name) -> FFoldType a -> Type -> Q a
    functorLikeTraverse InvariantClass
    iClass Map Name (Name, Name)
    tvMap (FT { ft_triv :: forall a. FFoldType a -> a
    ft_triv = a
    caseTrivial,     ft_var :: forall a. FFoldType a -> Name -> a
    ft_var = Name -> a
    caseVar
                                         , ft_co_var :: forall a. FFoldType a -> Name -> a
    ft_co_var = Name -> a
    caseCoVar,     ft_fun :: forall a. FFoldType a -> a -> a -> a
    ft_fun = a -> a -> a
    caseFun
                                         , ft_tup :: forall a. FFoldType a -> TupleSort -> [a] -> a
    ft_tup = TupleSort -> [a] -> a
    caseTuple,        ft_ty_app :: forall a. FFoldType a -> Bool -> [(Type, a, a)] -> a
    ft_ty_app = Bool -> [(Type, a, a)] -> a
    caseTyApp
                                         , ft_bad_app :: forall a. FFoldType a -> a
    ft_bad_app = a
    caseWrongArg, ft_forall :: forall a. FFoldType a -> [TyVarBndrSpec] -> a -> a
    ft_forall = [TyVarBndrSpec] -> a -> a
    caseForAll })
                        Type
    ty
      = do ty' <- Type -> Q Type
    resolveTypeSynonyms Type
    ty
           (res, _) <- go False ty'
           return res
      where
        {-
        go :: Bool        -- Covariant or contravariant context
           -> Type
           -> Q (a, Bool) -- (result of type a, does type contain var)
        -}
        go :: Bool -> Type -> Q (a, Bool)
    go Bool
    co t :: Type
    t@AppT{}
          | (Type
    ArrowT, [Type
    funArg, Type
    funRes]) <- Type -> (Type, [Type])
    unapplyTy Type
    t
          = do (funArgR, funArgC) <- Bool -> Type -> Q (a, Bool)
    go (Bool -> Bool
    not Bool
    co) Type
    funArg
               (funResR, funResC) <- go      co  funRes
               if funArgC || funResC
                  then return (caseFun funArgR funResR, True)
                  else trivial
        go Bool
    co t :: Type
    t@AppT{} = do
          let (Type
    f, [Type]
    args) = Type -> (Type, [Type])
    unapplyTy Type
    t
          (_, fc) <- Bool -> Type -> Q (a, Bool)
    go Bool
    co Type
    f
          (xrs,       xcs) <- fmap unzip $ mapM (go co) args
          (contraXrs, _)   <- fmap unzip $ mapM (go (not co)) args
          let numLastArgs, numFirstArgs :: Int
              numLastArgs  = Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    min (InvariantClass -> Int
    forall a. Enum a => a -> Int
    fromEnum InvariantClass
    iClass) ([Type] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Type]
    args)
              numFirstArgs = [Type] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Type]
    args Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    numLastArgs

              -- tuple :: TupleSort -> Q (a, Bool)
              tuple TupleSort
    tupSort = (a, Bool) -> m (a, Bool)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TupleSort -> [a] -> a
    caseTuple TupleSort
    tupSort [a]
    xrs, Bool
    True)

              -- wrongArg :: Q (a, Bool)
              wrongArg = (a, Bool) -> Q (a, Bool)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a
    caseWrongArg, Bool
    True)

          case () of
            ()
    _ |  Bool -> Bool
    not ([Bool] -> Bool
    forall (t :: * -> *). Foldable t => t Bool -> Bool
    or [Bool]
    xcs)
              -> Q (a, Bool)
    trivial -- Variable does not occur
              -- At this point we know that xrs, xcs is not empty,
              -- and at least one xr is True
              |  TupleT Int
    len <- Type
    f
              -> TupleSort -> Q (a, Bool)
    forall {m :: * -> *}. Monad m => TupleSort -> m (a, Bool)
    tuple (TupleSort -> Q (a, Bool)) -> TupleSort -> Q (a, Bool)
    forall a b. (a -> b) -> a -> b
    $ Int -> TupleSort
    Boxed Int
    len
              |  UnboxedTupleT Int
    len <- Type
    f
              -> TupleSort -> Q (a, Bool)
    forall {m :: * -> *}. Monad m => TupleSort -> m (a, Bool)
    tuple (TupleSort -> Q (a, Bool)) -> TupleSort -> Q (a, Bool)
    forall a b. (a -> b) -> a -> b
    $ Int -> TupleSort
    Unboxed Int
    len
              |  Bool
    fc Bool -> Bool -> Bool
    || [Bool] -> Bool
    forall (t :: * -> *). Foldable t => t Bool -> Bool
    or (Int -> [Bool] -> [Bool]
    forall a. Int -> [a] -> [a]
    take Int
    numFirstArgs [Bool]
    xcs)
              -> Q (a, Bool)
    wrongArg                    -- T (..var..)    ty_1 ... ty_n
              |  Bool
    otherwise                   -- T (..no var..) ty_1 ... ty_n
              -> do itf <- [Name] -> Type -> [Type] -> Q Bool
    isInTypeFamilyApp [Name]
    tyVarNames Type
    f [Type]
    args
                    if itf -- We can't decompose type families, so
                           -- error if we encounter one here.
                       then wrongArg
                       else return ( caseTyApp co $ drop numFirstArgs
                                                  $ zip3 args xrs contraXrs
                                   , True )
        go Bool
    co (SigT Type
    t Type
    k) = do
          (_, kc) <- Bool -> Type -> Q (a, Bool)
    go Bool
    co Type
    k
          if kc
             then return (caseWrongArg, True)
             else go co t
        go Bool
    co (VarT Name
    v)
          | Name -> Map Name (Name, Name) -> Bool
    forall k a. Ord k => k -> Map k a -> Bool
    Map.member Name
    v Map Name (Name, Name)
    tvMap
          = (a, Bool) -> Q (a, Bool)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (if Bool
    co then Name -> a
    caseCoVar Name
    v else Name -> a
    caseVar Name
    v, Bool
    True)
          | Bool
    otherwise
          = Q (a, Bool)
    trivial
        go Bool
    co (ForallT [TyVarBndrSpec]
    tvbs [Type]
    _ Type
    t) = do
          (tr, tc) <- Bool -> Type -> Q (a, Bool)
    go Bool
    co Type
    t
          let tvbNames = (TyVarBndrSpec -> Name) -> [TyVarBndrSpec] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndrSpec -> Name
    forall flag. TyVarBndr_ flag -> Name
    tvName [TyVarBndrSpec]
    tvbs
          if not tc || any (`elem` tvbNames) tyVarNames
             then trivial
             else return (caseForAll tvbs tr, True)
        go Bool
    _ Type
    _ = Q (a, Bool)
    trivial

        -- trivial :: Q (a, Bool)
        trivial :: Q (a, Bool)
    trivial = (a, Bool) -> Q (a, Bool)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a
    caseTrivial, Bool
    False)

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

    -- Fold over the arguments of a data constructor in a Functor-like way.
    foldDataConArgs :: InvariantClass -> TyVarMap -> FFoldType a -> ConstructorInfo -> Q [a]
    foldDataConArgs :: forall a.
    InvariantClass
    -> Map Name (Name, Name) -> FFoldType a -> ConstructorInfo -> Q [a]
    foldDataConArgs InvariantClass
    iClass Map Name (Name, Name)
    tvMap FFoldType a
    ft ConstructorInfo
    con = do
      fieldTys <- (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] -> Q [Type]) -> [Type] -> Q [Type]
    forall a b. (a -> b) -> a -> b
    $ ConstructorInfo -> [Type]
    constructorFields ConstructorInfo
    con
      mapM foldArg fieldTys
      where
        -- foldArg :: Type -> Q a
        foldArg :: Type -> Q a
    foldArg = InvariantClass
    -> Map Name (Name, Name) -> FFoldType a -> Type -> Q a
    forall a.
    InvariantClass
    -> Map Name (Name, Name) -> FFoldType a -> Type -> Q a
    functorLikeTraverse InvariantClass
    iClass Map Name (Name, Name)
    tvMap FFoldType a
    ft

    -- Make a 'LamE' using a fresh variable.
    mkSimpleLam :: (Exp -> Q Exp) -> Q Exp
    mkSimpleLam :: (Exp -> Q Exp) -> Q Exp
    mkSimpleLam Exp -> Q Exp
    lam = do
      n <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "n"
      lamE [varP n] (lam (VarE n))

    -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
    --
    -- @mkSimpleConMatch fold conName insides@ produces a match clause in
    -- which the LHS pattern-matches on @extraPats@, followed by a match on the
    -- constructor @conName@ and its arguments. The RHS folds (with @fold@) over
    -- @conName@ and its arguments, applying an expression (from @insides@) to each
    -- of the respective arguments of @conName@.
    mkSimpleConMatch :: (Name -> [a] -> Q Exp)
                     -> Name
                     -> [Exp -> a]
                     -> Q Match
    mkSimpleConMatch :: forall a. (Name -> [a] -> Q Exp) -> Name -> [Exp -> a] -> Q Match
    mkSimpleConMatch Name -> [a] -> Q Exp
    fold Name
    conName [Exp -> a]
    insides = do
      varsNeeded <- String -> Int -> Q [Name]
    newNameList String
    "_arg" (Int -> Q [Name]) -> Int -> Q [Name]
    forall a b. (a -> b) -> a -> b
    $ [Exp -> a] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Exp -> a]
    insides
      let pat = Name -> [Type] -> [Pat] -> Pat
    ConP Name
    conName
    #if MIN_VERSION_template_haskell(2,18,0)
                     []
    #endif
                     ((Name -> Pat) -> [Name] -> [Pat]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Pat
    VarP [Name]
    varsNeeded)
      rhs <- fold conName (zipWith (\Exp -> a
    i Name
    v -> Exp -> a
    i (Exp -> a) -> Exp -> a
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    VarE Name
    v) insides varsNeeded)
      return $ Match pat (NormalB rhs) []

    -- Indicates whether a tuple is boxed or unboxed, as well as its number of
    -- arguments. For instance, (a, b) corresponds to @Boxed 2@, and (# a, b, c #)
    -- corresponds to @Unboxed 3@.
    data TupleSort
      = Boxed   Int
      | Unboxed Int

    -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
    mkSimpleTupleCase :: (Name -> [a] -> Q Match)
                      -> TupleSort -> [a] -> Exp -> Q Exp
    mkSimpleTupleCase :: forall a.
    (Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
    mkSimpleTupleCase Name -> [a] -> Q Match
    matchForCon TupleSort
    tupSort [a]
    insides Exp
    x = do
      let tupDataName :: Name
    tupDataName = case TupleSort
    tupSort of
                          Boxed   Int
    len -> Int -> Name
    tupleDataName Int
    len
                          Unboxed Int
    len -> Int -> Name
    unboxedTupleDataName Int
    len
      m <- Name -> [a] -> Q Match
    matchForCon Name
    tupDataName [a]
    insides
      return $ CaseE x [m]