{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}

{- |
Module      :  Generics.Deriving.TH
Copyright   :  (c) 2008--2009 Universiteit Utrecht
License     :  BSD3

Maintainer  :  generics@haskell.org
Stability   :  experimental
Portability :  non-portable

This module contains Template Haskell code that can be used to
automatically generate the boilerplate code for the generic deriving
library.

To use these functions, pass the name of a data type as an argument:

@
{-# LANGUAGE TemplateHaskell #-}

data Example a = Example Int Char a
$('deriveAll0'     ''Example) -- Derives Generic instance
$('deriveAll1'     ''Example) -- Derives Generic1 instance
$('deriveAll0And1' ''Example) -- Derives Generic and Generic1 instances
@

On GHC 7.4 or later, this code can also be used with data families. To derive
for a data family instance, pass the name of one of the instance's constructors:

@
{-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-}

data family Family a b
newtype instance Family Char x = FamilyChar Char
data    instance Family Bool x = FamilyTrue | FamilyFalse

$('deriveAll0' 'FamilyChar) -- instance Generic (Family Char b) where ...
$('deriveAll1' 'FamilyTrue) -- instance Generic1 (Family Bool) where ...
-- Alternatively, one could type $(deriveAll1 'FamilyFalse)
@
-}

-- Adapted from Generics.Regular.TH
module Generics.Deriving.TH (
      -- * @derive@- functions
      deriveMeta
    , deriveData
    , deriveConstructors
    , deriveSelectors

    , deriveAll
    , deriveAll0
    , deriveAll1
    , deriveAll0And1
    , deriveRepresentable0
    , deriveRepresentable1
    , deriveRep0
    , deriveRep1

     -- * @make@- functions
     -- $make
    , makeRep0Inline
    , makeRep0
    , makeRep0FromType
    , makeFrom
    , makeFrom0
    , makeTo
    , makeTo0
    , makeRep1Inline
    , makeRep1
    , makeRep1FromType
    , makeFrom1
    , makeTo1

     -- * Options
     -- $options
     -- ** Option types
    , Options(..)
    , defaultOptions
    , RepOptions(..)
    , defaultRepOptions
    , KindSigOptions
    , defaultKindSigOptions
    , EmptyCaseOptions
    , defaultEmptyCaseOptions

    -- ** Functions with optional arguments
    , deriveAll0Options
    , deriveAll1Options
    , deriveAll0And1Options
    , deriveRepresentable0Options
    , deriveRepresentable1Options
    , deriveRep0Options
    , deriveRep1Options

    , makeFrom0Options
    , makeTo0Options
    , makeFrom1Options
    , makeTo1Options
  ) where

import           Control.Monad ((>=>), unless, when)

import qualified Data.Map as Map (empty, fromList)

import           Generics.Deriving.TH.Internal
import           Generics.Deriving.TH.Post4_9

import           Language.Haskell.TH.Datatype
import           Language.Haskell.TH.Datatype.TyVarBndr
import           Language.Haskell.TH.Lib
import           Language.Haskell.TH

{- $options
'Options' gives you a way to further tweak derived 'Generic' and 'Generic1' instances:

*   'RepOptions': By default, all derived 'Rep' and 'Rep1' type instances emit the code
    directly (the 'InlineRep' option). One can also choose to emit a separate type
    synonym for the 'Rep' type (this is the functionality of 'deriveRep0' and
    'deriveRep1') and define a 'Rep' instance in terms of that type synonym (the
    'TypeSynonymRep' option).

*   'EmptyCaseOptions': By default, all derived instances for empty data types
    (i.e., data types with no constructors) use 'error' in @from(1)@/@to(1)@.
    For instance, @data Empty@ would have this derived 'Generic' instance:

    @
    instance Generic Empty where
      type Rep Empty = D1 ('MetaData ...) V1
      from _ = M1 (error "No generic representation for empty datatype Empty")
      to (M1 _) = error "No generic representation for empty datatype Empty"
    @

    This matches the behavior of GHC up until 8.4, when derived @Generic(1)@
    instances began to use the @EmptyCase@ extension. In GHC 8.4, the derived
    'Generic' instance for @Empty@ would instead be:

    @
    instance Generic Empty where
      type Rep Empty = D1 ('MetaData ...) V1
      from x = M1 (case x of {})
      to (M1 x) = case x of {}
    @

    This is a slightly better encoding since, for example, any divergent
    computations passed to 'from' will actually diverge (as opposed to before,
    where the result would always be a call to 'error'). On the other hand, using
    this encoding in @generic-deriving@ has one large drawback: it requires
    enabling @EmptyCase@, an extension which was only introduced in GHC 7.8
    (and only received reliable pattern-match coverage checking in 8.2).

    The 'EmptyCaseOptions' field controls whether code should be emitted that
    uses @EmptyCase@ (i.e., 'EmptyCaseOptions' set to 'True') or not ('False').
    The default value is 'False'. Note that even if set to 'True', this option
    has no effect on GHCs before 7.8, as @EmptyCase@ did not exist then.

*   'KindSigOptions': By default, all derived instances will use explicit kind
    signatures (when the 'KindSigOptions' is 'True'). You might wish to set the
    'KindSigOptions' to 'False' if you want a 'Generic'/'Generic1' instance at
    a particular kind that GHC will infer correctly, but the functions in this
    module won't guess correctly. You probably won't ever need this option
    unless you are a power user.
-}

-- | Additional options for configuring derived 'Generic'/'Generic1' instances
-- using Template Haskell.
data Options = Options
  { Options -> RepOptions
repOptions       :: RepOptions
  , Options -> KindSigOptions
kindSigOptions   :: KindSigOptions
  , Options -> KindSigOptions
emptyCaseOptions :: EmptyCaseOptions
  } deriving (Options -> Options -> KindSigOptions
(Options -> Options -> KindSigOptions)
-> (Options -> Options -> KindSigOptions) -> Eq Options
forall a.
(a -> a -> KindSigOptions) -> (a -> a -> KindSigOptions) -> Eq a
$c== :: Options -> Options -> KindSigOptions
== :: Options -> Options -> KindSigOptions
$c/= :: Options -> Options -> KindSigOptions
/= :: Options -> Options -> KindSigOptions
Eq, Eq Options
Eq Options =>
(Options -> Options -> Ordering)
-> (Options -> Options -> KindSigOptions)
-> (Options -> Options -> KindSigOptions)
-> (Options -> Options -> KindSigOptions)
-> (Options -> Options -> KindSigOptions)
-> (Options -> Options -> Options)
-> (Options -> Options -> Options)
-> Ord Options
Options -> Options -> KindSigOptions
Options -> Options -> Ordering
Options -> Options -> Options
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> KindSigOptions)
-> (a -> a -> KindSigOptions)
-> (a -> a -> KindSigOptions)
-> (a -> a -> KindSigOptions)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Options -> Options -> Ordering
compare :: Options -> Options -> Ordering
$c< :: Options -> Options -> KindSigOptions
< :: Options -> Options -> KindSigOptions
$c<= :: Options -> Options -> KindSigOptions
<= :: Options -> Options -> KindSigOptions
$c> :: Options -> Options -> KindSigOptions
> :: Options -> Options -> KindSigOptions
$c>= :: Options -> Options -> KindSigOptions
>= :: Options -> Options -> KindSigOptions
$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)

-- | Sensible default 'Options'.
defaultOptions :: Options
defaultOptions :: Options
defaultOptions = Options
  { repOptions :: RepOptions
repOptions       = RepOptions
defaultRepOptions
  , kindSigOptions :: KindSigOptions
kindSigOptions   = KindSigOptions
defaultKindSigOptions
  , emptyCaseOptions :: KindSigOptions
emptyCaseOptions = KindSigOptions
defaultEmptyCaseOptions
  }

-- | Configures whether 'Rep'/'Rep1' type instances should be defined inline in a
-- derived 'Generic'/'Generic1' instance ('InlineRep') or defined in terms of a
-- type synonym ('TypeSynonymRep').
data RepOptions = InlineRep
                | TypeSynonymRep
  deriving (RepOptions -> RepOptions -> KindSigOptions
(RepOptions -> RepOptions -> KindSigOptions)
-> (RepOptions -> RepOptions -> KindSigOptions) -> Eq RepOptions
forall a.
(a -> a -> KindSigOptions) -> (a -> a -> KindSigOptions) -> Eq a
$c== :: RepOptions -> RepOptions -> KindSigOptions
== :: RepOptions -> RepOptions -> KindSigOptions
$c/= :: RepOptions -> RepOptions -> KindSigOptions
/= :: RepOptions -> RepOptions -> KindSigOptions
Eq, Eq RepOptions
Eq RepOptions =>
(RepOptions -> RepOptions -> Ordering)
-> (RepOptions -> RepOptions -> KindSigOptions)
-> (RepOptions -> RepOptions -> KindSigOptions)
-> (RepOptions -> RepOptions -> KindSigOptions)
-> (RepOptions -> RepOptions -> KindSigOptions)
-> (RepOptions -> RepOptions -> RepOptions)
-> (RepOptions -> RepOptions -> RepOptions)
-> Ord RepOptions
RepOptions -> RepOptions -> KindSigOptions
RepOptions -> RepOptions -> Ordering
RepOptions -> RepOptions -> RepOptions
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> KindSigOptions)
-> (a -> a -> KindSigOptions)
-> (a -> a -> KindSigOptions)
-> (a -> a -> KindSigOptions)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: RepOptions -> RepOptions -> Ordering
compare :: RepOptions -> RepOptions -> Ordering
$c< :: RepOptions -> RepOptions -> KindSigOptions
< :: RepOptions -> RepOptions -> KindSigOptions
$c<= :: RepOptions -> RepOptions -> KindSigOptions
<= :: RepOptions -> RepOptions -> KindSigOptions
$c> :: RepOptions -> RepOptions -> KindSigOptions
> :: RepOptions -> RepOptions -> KindSigOptions
$c>= :: RepOptions -> RepOptions -> KindSigOptions
>= :: RepOptions -> RepOptions -> KindSigOptions
$cmax :: RepOptions -> RepOptions -> RepOptions
max :: RepOptions -> RepOptions -> RepOptions
$cmin :: RepOptions -> RepOptions -> RepOptions
min :: RepOptions -> RepOptions -> RepOptions
Ord, ReadPrec [RepOptions]
ReadPrec RepOptions
Int -> ReadS RepOptions
ReadS [RepOptions]
(Int -> ReadS RepOptions)
-> ReadS [RepOptions]
-> ReadPrec RepOptions
-> ReadPrec [RepOptions]
-> Read RepOptions
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS RepOptions
readsPrec :: Int -> ReadS RepOptions
$creadList :: ReadS [RepOptions]
readList :: ReadS [RepOptions]
$creadPrec :: ReadPrec RepOptions
readPrec :: ReadPrec RepOptions
$creadListPrec :: ReadPrec [RepOptions]
readListPrec :: ReadPrec [RepOptions]
Read, Int -> RepOptions -> ShowS
[RepOptions] -> ShowS
RepOptions -> String
(Int -> RepOptions -> ShowS)
-> (RepOptions -> String)
-> ([RepOptions] -> ShowS)
-> Show RepOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RepOptions -> ShowS
showsPrec :: Int -> RepOptions -> ShowS
$cshow :: RepOptions -> String
show :: RepOptions -> String
$cshowList :: [RepOptions] -> ShowS
showList :: [RepOptions] -> ShowS
Show)

-- | 'InlineRep', a sensible default 'RepOptions'.
defaultRepOptions :: RepOptions
defaultRepOptions :: RepOptions
defaultRepOptions = RepOptions
InlineRep

-- | 'True' if explicit kind signatures should be used in derived
-- 'Generic'/'Generic1' instances, 'False' otherwise.
type KindSigOptions = Bool

-- | 'True', a sensible default 'KindSigOptions'.
defaultKindSigOptions :: KindSigOptions
defaultKindSigOptions :: KindSigOptions
defaultKindSigOptions = KindSigOptions
True

-- | 'True' if generated code for empty data types should use the @EmptyCase@
-- extension, 'False' otherwise. This has no effect on GHCs before 7.8, since
-- @EmptyCase@ is only available in 7.8 or later.
type EmptyCaseOptions = Bool

-- | Sensible default 'EmptyCaseOptions'.
defaultEmptyCaseOptions :: EmptyCaseOptions
defaultEmptyCaseOptions :: KindSigOptions
defaultEmptyCaseOptions = KindSigOptions
False

-- | A backwards-compatible synonym for 'deriveAll0'.
deriveAll :: Name -> Q [Dec]
deriveAll :: Name -> Q [Dec]
deriveAll = Name -> Q [Dec]
deriveAll0

-- | Given the type and the name (as string) for the type to derive,
-- generate the 'Data' instance, the 'Constructor' instances, the 'Selector'
-- instances, and the 'Representable0' instance.
deriveAll0 :: Name -> Q [Dec]
deriveAll0 :: Name -> Q [Dec]
deriveAll0 = Options -> Name -> Q [Dec]
deriveAll0Options Options
defaultOptions

-- | Like 'deriveAll0', but takes an 'Options' argument.
deriveAll0Options :: Options -> Name -> Q [Dec]
deriveAll0Options :: Options -> Name -> Q [Dec]
deriveAll0Options = KindSigOptions -> KindSigOptions -> Options -> Name -> Q [Dec]
deriveAllCommon KindSigOptions
True KindSigOptions
False

-- | Given the type and the name (as string) for the type to derive,
-- generate the 'Data' instance, the 'Constructor' instances, the 'Selector'
-- instances, and the 'Representable1' instance.
deriveAll1 :: Name -> Q [Dec]
deriveAll1 :: Name -> Q [Dec]
deriveAll1 = Options -> Name -> Q [Dec]
deriveAll1Options Options
defaultOptions

-- | Like 'deriveAll1', but takes an 'Options' argument.
deriveAll1Options :: Options -> Name -> Q [Dec]
deriveAll1Options :: Options -> Name -> Q [Dec]
deriveAll1Options = KindSigOptions -> KindSigOptions -> Options -> Name -> Q [Dec]
deriveAllCommon KindSigOptions
False KindSigOptions
True

-- | Given the type and the name (as string) for the type to derive,
-- generate the 'Data' instance, the 'Constructor' instances, the 'Selector'
-- instances, the 'Representable0' instance, and the 'Representable1' instance.
deriveAll0And1 :: Name -> Q [Dec]
deriveAll0And1 :: Name -> Q [Dec]
deriveAll0And1 = Options -> Name -> Q [Dec]
deriveAll0And1Options Options
defaultOptions

-- | Like 'deriveAll0And1', but takes an 'Options' argument.
deriveAll0And1Options :: Options -> Name -> Q [Dec]
deriveAll0And1Options :: Options -> Name -> Q [Dec]
deriveAll0And1Options = KindSigOptions -> KindSigOptions -> Options -> Name -> Q [Dec]
deriveAllCommon KindSigOptions
True KindSigOptions
True

deriveAllCommon :: Bool -> Bool -> Options -> Name -> Q [Dec]
deriveAllCommon :: KindSigOptions -> KindSigOptions -> Options -> Name -> Q [Dec]
deriveAllCommon KindSigOptions
generic KindSigOptions
generic1 Options
opts Name
n = do
    a <- Name -> Q [Dec]
deriveMeta Name
n
    b <- if generic
            then deriveRepresentableCommon Generic opts n
            else return []
    c <- if generic1
            then deriveRepresentableCommon Generic1 opts n
            else return []
    return (a ++ b ++ c)

-- | Given the type and the name (as string) for the Representable0 type
-- synonym to derive, generate the 'Representable0' instance.
deriveRepresentable0 :: Name -> Q [Dec]
deriveRepresentable0 :: Name -> Q [Dec]
deriveRepresentable0 = Options -> Name -> Q [Dec]
deriveRepresentable0Options Options
defaultOptions

-- | Like 'deriveRepresentable0', but takes an 'Options' argument.
deriveRepresentable0Options :: Options -> Name -> Q [Dec]
deriveRepresentable0Options :: Options -> Name -> Q [Dec]
deriveRepresentable0Options = GenericClass -> Options -> Name -> Q [Dec]
deriveRepresentableCommon GenericClass
Generic

-- | Given the type and the name (as string) for the Representable1 type
-- synonym to derive, generate the 'Representable1' instance.
deriveRepresentable1 :: Name -> Q [Dec]
deriveRepresentable1 :: Name -> Q [Dec]
deriveRepresentable1 = Options -> Name -> Q [Dec]
deriveRepresentable1Options Options
defaultOptions

-- | Like 'deriveRepresentable1', but takes an 'Options' argument.
deriveRepresentable1Options :: Options -> Name -> Q [Dec]
deriveRepresentable1Options :: Options -> Name -> Q [Dec]
deriveRepresentable1Options = GenericClass -> Options -> Name -> Q [Dec]
deriveRepresentableCommon GenericClass
Generic1

deriveRepresentableCommon :: GenericClass -> Options -> Name -> Q [Dec]
deriveRepresentableCommon :: GenericClass -> Options -> Name -> Q [Dec]
deriveRepresentableCommon GenericClass
gClass Options
opts Name
n = do
    rep  <- if Options -> RepOptions
repOptions Options
opts RepOptions -> RepOptions -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== RepOptions
InlineRep
               then [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
               else GenericClass -> KindSigOptions -> Name -> Q [Dec]
deriveRepCommon GenericClass
gClass (Options -> KindSigOptions
kindSigOptions Options
opts) Name
n
    inst <- deriveInst gClass opts n
    return (rep ++ inst)

-- | Derive only the 'Rep0' type synonym. Not needed if 'deriveRepresentable0'
-- is used.
deriveRep0 :: Name -> Q [Dec]
deriveRep0 :: Name -> Q [Dec]
deriveRep0 = KindSigOptions -> Name -> Q [Dec]
deriveRep0Options KindSigOptions
defaultKindSigOptions

-- | Like 'deriveRep0', but takes an 'KindSigOptions' argument.
deriveRep0Options :: KindSigOptions -> Name -> Q [Dec]
deriveRep0Options :: KindSigOptions -> Name -> Q [Dec]
deriveRep0Options = GenericClass -> KindSigOptions -> Name -> Q [Dec]
deriveRepCommon GenericClass
Generic

-- | Derive only the 'Rep1' type synonym. Not needed if 'deriveRepresentable1'
-- is used.
deriveRep1 :: Name -> Q [Dec]
deriveRep1 :: Name -> Q [Dec]
deriveRep1 = KindSigOptions -> Name -> Q [Dec]
deriveRep1Options KindSigOptions
defaultKindSigOptions

-- | Like 'deriveRep1', but takes an 'KindSigOptions' argument.
deriveRep1Options :: KindSigOptions -> Name -> Q [Dec]
deriveRep1Options :: KindSigOptions -> Name -> Q [Dec]
deriveRep1Options = GenericClass -> KindSigOptions -> Name -> Q [Dec]
deriveRepCommon GenericClass
Generic1

deriveRepCommon :: GenericClass -> KindSigOptions -> Name -> Q [Dec]
deriveRepCommon :: GenericClass -> KindSigOptions -> Name -> Q [Dec]
deriveRepCommon GenericClass
gClass KindSigOptions
useKindSigs Name
n = do
  i <- Name
-> Q (Either
        String (Name, [Type], [ConstructorInfo], DatatypeVariant_))
reifyDataInfo Name
n
  let (name, instTys, cons, dv) = either error id i
      gt = GenericClass -> [Type] -> GenericTvbs
mkGenericTvbs GenericClass
gClass [Type]
instTys
  -- See Note [Forcing buildTypeInstance]
  !_ <- buildTypeInstance gClass useKindSigs name instTys

  -- See Note [Kind signatures in derived instances]
  let tySynVars  = GenericTvbs -> [TyVarBndrUnit]
genericInitTvbs GenericTvbs
gt
      tySynVars' = if KindSigOptions
useKindSigs
                      then [TyVarBndrUnit]
tySynVars
                      else (TyVarBndrUnit -> TyVarBndrUnit)
-> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> TyVarBndrUnit
unKindedTV [TyVarBndrUnit]
tySynVars
  fmap (:[]) $ tySynD (genRepName gClass dv name)
                      (changeTVFlags bndrReq tySynVars')
                      (repType gt dv name Map.empty cons)

deriveInst :: GenericClass -> Options -> Name -> Q [Dec]
deriveInst :: GenericClass -> Options -> Name -> Q [Dec]
deriveInst GenericClass
Generic  = Name
-> Name
-> GenericClass
-> Name
-> Name
-> Options
-> Name
-> Q [Dec]
deriveInstCommon Name
genericTypeName  Name
repTypeName  GenericClass
Generic  Name
fromValName  Name
toValName
deriveInst GenericClass
Generic1 = Name
-> Name
-> GenericClass
-> Name
-> Name
-> Options
-> Name
-> Q [Dec]
deriveInstCommon Name
generic1TypeName Name
rep1TypeName GenericClass
Generic1 Name
from1ValName Name
to1ValName

deriveInstCommon :: Name
                 -> Name
                 -> GenericClass
                 -> Name
                 -> Name
                 -> Options
                 -> Name
                 -> Q [Dec]
deriveInstCommon :: Name
-> Name
-> GenericClass
-> Name
-> Name
-> Options
-> Name
-> Q [Dec]
deriveInstCommon Name
genericName Name
repName GenericClass
gClass Name
fromName Name
toName Options
opts Name
n = do
  i <- Name
-> Q (Either
        String (Name, [Type], [ConstructorInfo], DatatypeVariant_))
reifyDataInfo Name
n
  let (name, instTys, cons, dv) = either error id i
      gt = GenericClass -> [Type] -> GenericTvbs
mkGenericTvbs GenericClass
gClass [Type]
instTys
      useKindSigs = Options -> KindSigOptions
kindSigOptions Options
opts
  -- See Note [Forcing buildTypeInstance]
  !(origTy, origKind) <- buildTypeInstance gClass useKindSigs name instTys
  tyInsRHS <- if repOptions opts == InlineRep
                 then repType gt dv name Map.empty cons
                 else makeRepTySynApp gClass dv name origTy

  let origSigTy = if KindSigOptions
useKindSigs
                     then Type -> Type -> Type
SigT Type
origTy Type
origKind
                     else Type
origTy
  tyIns <- tySynInstDCompat repName Nothing [return origSigTy] (return tyInsRHS)
  let ecOptions = Options -> KindSigOptions
emptyCaseOptions Options
opts
      mkBody GenericTvbs
-> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match
maker = [[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
$
                              Q Match -> Q Exp
mkCaseExp (Q Match -> Q Exp) -> Q Match -> Q Exp
forall a b. (a -> b) -> a -> b
$
                              GenericTvbs
-> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match
maker GenericTvbs
gt KindSigOptions
ecOptions Name
name [ConstructorInfo]
cons)
                             []]
      fcs = (GenericTvbs
 -> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match)
-> [Q Clause]
mkBody GenericTvbs
-> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match
mkFrom
      tcs = (GenericTvbs
 -> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match)
-> [Q Clause]
mkBody GenericTvbs
-> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match
mkTo

      inline_pragmas
        | [ConstructorInfo] -> KindSigOptions
inlining_useful [ConstructorInfo]
cons
        = (Name -> Q Dec) -> [Name] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
fun_name ->
                Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
fun_name
                         Inline
Inline RuleMatch
FunLike (Int -> Phases
FromPhase Int
1)
              ) [Name
fromName, Name
toName]
        | KindSigOptions
otherwise
        = []

  fmap (:[]) $
    instanceD (cxt []) (conT genericName `appT` return origSigTy)
                       (inline_pragmas ++ [return tyIns, funD fromName fcs, funD toName tcs])
  where
    -- Adapted from inlining_useful in GHC.Tc.Deriv.Generics.mkBindsRep in the
    -- GHC source code:
    --
    -- https://gitlab.haskell.org/ghc/ghc/-/blob/80729d96e47c99dc38e83612dfcfe01cf565eac0/compiler/GHC/Tc/Deriv/Generics.hs#L368-386
    inlining_useful :: [ConstructorInfo] -> KindSigOptions
inlining_useful [ConstructorInfo]
cons
      | Int
ncons Int -> Int -> KindSigOptions
forall a. Ord a => a -> a -> KindSigOptions
<= Int
1  = KindSigOptions
True
      | Int
ncons Int -> Int -> KindSigOptions
forall a. Ord a => a -> a -> KindSigOptions
<= Int
4  = Int
max_fields Int -> Int -> KindSigOptions
forall a. Ord a => a -> a -> KindSigOptions
<= Int
5
      | Int
ncons Int -> Int -> KindSigOptions
forall a. Ord a => a -> a -> KindSigOptions
<= Int
8  = Int
max_fields Int -> Int -> KindSigOptions
forall a. Ord a => a -> a -> KindSigOptions
<= Int
2
      | Int
ncons Int -> Int -> KindSigOptions
forall a. Ord a => a -> a -> KindSigOptions
<= Int
16 = Int
max_fields Int -> Int -> KindSigOptions
forall a. Ord a => a -> a -> KindSigOptions
<= Int
1
      | Int
ncons Int -> Int -> KindSigOptions
forall a. Ord a => a -> a -> KindSigOptions
<= Int
24 = Int
max_fields Int -> Int -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Int
0
      | KindSigOptions
otherwise   = KindSigOptions
False
      where
        ncons :: Int
ncons      = [ConstructorInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cons
        max_fields :: Int
max_fields = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (ConstructorInfo -> Int) -> [ConstructorInfo] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Type] -> Int)
-> (ConstructorInfo -> [Type]) -> ConstructorInfo -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorInfo -> [Type]
constructorFields) [ConstructorInfo]
cons

{- $make

There are some data types for which the Template Haskell deriver functions in
this module are not sophisticated enough to infer the correct 'Generic' or
'Generic1' instances. As an example, consider this data type:

@
newtype Fix f a = Fix (f (Fix f a))
@

A proper 'Generic1' instance would look like this:

@
instance Functor f => Generic1 (Fix f) where ...
@

Unfortunately, 'deriveRepresentable1' cannot infer the @Functor f@ constraint.
One can still define a 'Generic1' instance for @Fix@, however, by using the
functions in this module that are prefixed with @make@-. For example:

@
$('deriveMeta' ''Fix)
$('deriveRep1' ''Fix)
instance Functor f => Generic1 (Fix f) where
  type Rep1 (Fix f) = $('makeRep1Inline' ''Fix [t| Fix f |])
  from1 = $('makeFrom1' ''Fix)
  to1   = $('makeTo1'   ''Fix)
@

Note that due to the lack of type-level lambdas in Haskell, one must manually
apply @'makeRep1Inline' ''Fix@ to the type @Fix f@.

Be aware that there is a bug on GHC 7.0, 7.2, and 7.4 which might prevent you from
using 'makeRep0Inline' and 'makeRep1Inline'. In the @Fix@ example above, you
would experience the following error:

@
    Kinded thing `f' used as a type
    In the Template Haskell quotation [t| Fix f |]
@

Then a workaround is to use 'makeRep1' instead, which requires you to:

1. Invoke 'deriveRep1' beforehand

2. Pass as arguments the type variables that occur in the instance, in order
   from left to right, topologically sorted, excluding duplicates. (Normally,
   'makeRep1Inline' would figure this out for you.)

Using the above example:

@
$('deriveMeta' ''Fix)
$('deriveRep1' ''Fix)
instance Functor f => Generic1 (Fix f) where
  type Rep1 (Fix f) = $('makeRep1' ''Fix) f
  from1 = $('makeFrom1' ''Fix)
  to1   = $('makeTo1'   ''Fix)
@

On GHC 7.4, you might encounter more complicated examples involving data
families. For instance:

@
data family Fix a b c d
newtype instance Fix b (f c) (g b) a = Fix (f (Fix b (f c) (g b) a))

$('deriveMeta' ''Fix)
$('deriveRep1' ''Fix)
instance Functor f => Generic1 (Fix b (f c) (g b)) where
  type Rep1 (Fix b (f c) (g b)) = $('makeRep1' 'Fix) b f c g
  from1 = $('makeFrom1' 'Fix)
  to1   = $('makeTo1'   'Fix)
@

Note that you don't pass @b@ twice, only once.
-}

-- | Generates the full 'Rep' type inline. Since this type can be quite
-- large, it is recommended you only use this to define 'Rep', e.g.,
--
-- @
-- type Rep (Foo (a :: k) b) = $('makeRep0Inline' ''Foo [t| Foo (a :: k) b |])
-- @
--
-- You can then simply refer to @Rep (Foo a b)@ elsewhere.
--
-- Note that the type passed as an argument to 'makeRep0Inline' must match the
-- type argument of 'Rep' exactly, even up to including the explicit kind
-- signature on @a@. This is due to a limitation of Template Haskell—without
-- the kind signature, 'makeRep0Inline' has no way of figuring out the kind of
-- @a@, and the generated type might be completely wrong as a result!
makeRep0Inline :: Name -> Q Type -> Q Type
makeRep0Inline :: Name -> Q Type -> Q Type
makeRep0Inline Name
n = GenericClass -> RepOptions -> Name -> Maybe (Q Type) -> Q Type
makeRepCommon GenericClass
Generic RepOptions
InlineRep Name
n (Maybe (Q Type) -> Q Type)
-> (Q Type -> Maybe (Q Type)) -> Q Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Type -> Maybe (Q Type)
forall a. a -> Maybe a
Just

-- | Generates the full 'Rep1' type inline. Since this type can be quite
-- large, it is recommended you only use this to define 'Rep1', e.g.,
--
-- @
-- type Rep1 (Foo (a :: k)) = $('makeRep0Inline' ''Foo [t| Foo (a :: k) |])
-- @
--
-- You can then simply refer to @Rep1 (Foo a)@ elsewhere.
--
-- Note that the type passed as an argument to 'makeRep1Inline' must match the
-- type argument of 'Rep1' exactly, even up to including the explicit kind
-- signature on @a@. This is due to a limitation of Template Haskell—without
-- the kind signature, 'makeRep1Inline' has no way of figuring out the kind of
-- @a@, and the generated type might be completely wrong as a result!
makeRep1Inline :: Name -> Q Type -> Q Type
makeRep1Inline :: Name -> Q Type -> Q Type
makeRep1Inline Name
n = GenericClass -> RepOptions -> Name -> Maybe (Q Type) -> Q Type
makeRepCommon GenericClass
Generic1 RepOptions
InlineRep Name
n (Maybe (Q Type) -> Q Type)
-> (Q Type -> Maybe (Q Type)) -> Q Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Type -> Maybe (Q Type)
forall a. a -> Maybe a
Just

-- | Generates the 'Rep' type synonym constructor (as opposed to 'deriveRep0',
-- which generates the type synonym declaration). After splicing it into
-- Haskell source, it expects types as arguments. For example:
--
-- @
-- type Rep (Foo a b) = $('makeRep0' ''Foo) a b
-- @
--
-- The use of 'makeRep0' is generally discouraged, as it can sometimes be
-- difficult to predict the order in which you are expected to pass type
-- variables. As a result, 'makeRep0Inline' is recommended instead. However,
-- 'makeRep0Inline' is not usable on GHC 7.0, 7.2, or 7.4 due to a GHC bug,
-- so 'makeRep0' still exists for GHC 7.0, 7.2, and 7.4 users.
makeRep0 :: Name -> Q Type
makeRep0 :: Name -> Q Type
makeRep0 Name
n = GenericClass -> RepOptions -> Name -> Maybe (Q Type) -> Q Type
makeRepCommon GenericClass
Generic RepOptions
TypeSynonymRep Name
n Maybe (Q Type)
forall a. Maybe a
Nothing

-- | Generates the 'Rep1' type synonym constructor (as opposed to 'deriveRep1',
-- which generates the type synonym declaration). After splicing it into
-- Haskell source, it expects types as arguments. For example:
--
-- @
-- type Rep1 (Foo a) = $('makeRep1' ''Foo) a
-- @
--
-- The use of 'makeRep1' is generally discouraged, as it can sometimes be
-- difficult to predict the order in which you are expected to pass type
-- variables. As a result, 'makeRep1Inline' is recommended instead. However,
-- 'makeRep1Inline' is not usable on GHC 7.0, 7.2, or 7.4 due to a GHC bug,
-- so 'makeRep1' still exists for GHC 7.0, 7.2, and 7.4 users.
makeRep1 :: Name -> Q Type
makeRep1 :: Name -> Q Type
makeRep1 Name
n = GenericClass -> RepOptions -> Name -> Maybe (Q Type) -> Q Type
makeRepCommon GenericClass
Generic1 RepOptions
TypeSynonymRep Name
n Maybe (Q Type)
forall a. Maybe a
Nothing

-- | Generates the 'Rep' type synonym constructor (as opposed to 'deriveRep0',
-- which generates the type synonym declaration) applied to its type arguments.
-- Unlike 'makeRep0', this also takes a quoted 'Type' as an argument, e.g.,
--
-- @
-- type Rep (Foo (a :: k) b) = $('makeRep0FromType' ''Foo [t| Foo (a :: k) b |])
-- @
--
-- Note that the type passed as an argument to 'makeRep0FromType' must match the
-- type argument of 'Rep' exactly, even up to including the explicit kind
-- signature on @a@. This is due to a limitation of Template Haskell—without
-- the kind signature, 'makeRep0FromType' has no way of figuring out the kind of
-- @a@, and the generated type might be completely wrong as a result!
--
-- The use of 'makeRep0FromType' is generally discouraged, since 'makeRep0Inline'
-- does exactly the same thing but without having to go through an intermediate
-- type synonym, and as a result, 'makeRep0Inline' tends to be less buggy.
makeRep0FromType :: Name -> Q Type -> Q Type
makeRep0FromType :: Name -> Q Type -> Q Type
makeRep0FromType Name
n = GenericClass -> RepOptions -> Name -> Maybe (Q Type) -> Q Type
makeRepCommon GenericClass
Generic RepOptions
TypeSynonymRep Name
n (Maybe (Q Type) -> Q Type)
-> (Q Type -> Maybe (Q Type)) -> Q Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Type -> Maybe (Q Type)
forall a. a -> Maybe a
Just

-- | Generates the 'Rep1' type synonym constructor (as opposed to 'deriveRep1',
-- which generates the type synonym declaration) applied to its type arguments.
-- Unlike 'makeRep1', this also takes a quoted 'Type' as an argument, e.g.,
--
-- @
-- type Rep1 (Foo (a :: k)) = $('makeRep1FromType' ''Foo [t| Foo (a :: k) |])
-- @
--
-- Note that the type passed as an argument to 'makeRep1FromType' must match the
-- type argument of 'Rep' exactly, even up to including the explicit kind
-- signature on @a@. This is due to a limitation of Template Haskell—without
-- the kind signature, 'makeRep1FromType' has no way of figuring out the kind of
-- @a@, and the generated type might be completely wrong as a result!
--
-- The use of 'makeRep1FromType' is generally discouraged, since 'makeRep1Inline'
-- does exactly the same thing but without having to go through an intermediate
-- type synonym, and as a result, 'makeRep1Inline' tends to be less buggy.
makeRep1FromType :: Name -> Q Type -> Q Type
makeRep1FromType :: Name -> Q Type -> Q Type
makeRep1FromType Name
n = GenericClass -> RepOptions -> Name -> Maybe (Q Type) -> Q Type
makeRepCommon GenericClass
Generic1 RepOptions
TypeSynonymRep Name
n (Maybe (Q Type) -> Q Type)
-> (Q Type -> Maybe (Q Type)) -> Q Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Type -> Maybe (Q Type)
forall a. a -> Maybe a
Just

makeRepCommon :: GenericClass
              -> RepOptions
              -> Name
              -> Maybe (Q Type)
              -> Q Type
makeRepCommon :: GenericClass -> RepOptions -> Name -> Maybe (Q Type) -> Q Type
makeRepCommon GenericClass
gClass RepOptions
repOpts Name
n Maybe (Q Type)
mbQTy = do
  i <- Name
-> Q (Either
        String (Name, [Type], [ConstructorInfo], DatatypeVariant_))
reifyDataInfo Name
n
  let (name, instTys, cons, dv) = either error id i
      gt = GenericClass -> [Type] -> GenericTvbs
mkGenericTvbs GenericClass
gClass [Type]
instTys
  -- See Note [Forcing buildTypeInstance]
  !_ <- buildTypeInstance gClass False name instTys

  case (mbQTy, repOpts) of
       (Just Q Type
qTy, RepOptions
TypeSynonymRep) -> Q Type
qTy Q Type -> (Type -> Q Type) -> Q Type
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GenericClass -> DatatypeVariant_ -> Name -> Type -> Q Type
makeRepTySynApp GenericClass
gClass DatatypeVariant_
dv Name
name
       (Just Q Type
qTy, RepOptions
InlineRep)      -> Q Type
qTy Q Type -> (Type -> Q Type) -> Q Type
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GenericTvbs
-> DatatypeVariant_ -> Name -> [ConstructorInfo] -> Type -> Q Type
makeRepInline GenericTvbs
gt DatatypeVariant_
dv Name
name [ConstructorInfo]
cons
       (Maybe (Q Type)
Nothing,  RepOptions
TypeSynonymRep) -> Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ GenericClass -> DatatypeVariant_ -> Name -> Name
genRepName GenericClass
gClass DatatypeVariant_
dv Name
name
       (Maybe (Q Type)
Nothing,  RepOptions
InlineRep)      -> String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeRepCommon"

makeRepInline :: GenericTvbs
              -> DatatypeVariant_
              -> Name
              -> [ConstructorInfo]
              -> Type
              -> Q Type
makeRepInline :: GenericTvbs
-> DatatypeVariant_ -> Name -> [ConstructorInfo] -> Type -> Q Type
makeRepInline GenericTvbs
gt DatatypeVariant_
dv Name
name [ConstructorInfo]
cons Type
ty = do
  let instVars :: [TyVarBndrUnit]
instVars = [Type] -> [TyVarBndrUnit]
freeVariablesWellScoped [Type
ty]
      tySynVars :: [TyVarBndrUnit]
tySynVars = GenericTvbs -> [TyVarBndrUnit]
genericInitTvbs GenericTvbs
gt

      typeSubst :: TypeSubst
      typeSubst :: TypeSubst
typeSubst = [(Name, Type)] -> TypeSubst
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Type)] -> TypeSubst) -> [(Name, Type)] -> TypeSubst
forall a b. (a -> b) -> a -> b
$
        [Name] -> [Type] -> [(Name, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((TyVarBndrUnit -> Name) -> [TyVarBndrUnit] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName [TyVarBndrUnit]
tySynVars)
            ((TyVarBndrUnit -> Type) -> [TyVarBndrUnit] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT (Name -> Type) -> (TyVarBndrUnit -> Name) -> TyVarBndrUnit -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName) [TyVarBndrUnit]
instVars)

  GenericTvbs
-> DatatypeVariant_
-> Name
-> TypeSubst
-> [ConstructorInfo]
-> Q Type
repType GenericTvbs
gt DatatypeVariant_
dv Name
name TypeSubst
typeSubst [ConstructorInfo]
cons

makeRepTySynApp :: GenericClass -> DatatypeVariant_ -> Name
                -> Type -> Q Type
makeRepTySynApp :: GenericClass -> DatatypeVariant_ -> Name -> Type -> Q Type
makeRepTySynApp GenericClass
gClass DatatypeVariant_
dv Name
name Type
ty =
  -- Here, we figure out the distinct type variables (in order from left-to-right)
  -- of the LHS of the Rep(1) instance. We call unKindedTV because the kind
  -- inferencer can figure out the kinds perfectly well, so we don't need to
  -- give anything here explicit kind signatures.
  let instTvbs :: [TyVarBndrUnit]
instTvbs = (TyVarBndrUnit -> TyVarBndrUnit)
-> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> TyVarBndrUnit
unKindedTV ([TyVarBndrUnit] -> [TyVarBndrUnit])
-> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a b. (a -> b) -> a -> b
$ [Type] -> [TyVarBndrUnit]
freeVariablesWellScoped [Type
ty]
  in Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> [TyVarBndrUnit] -> Type
forall flag. Name -> [TyVarBndr_ flag] -> Type
applyTyToTvbs (GenericClass -> DatatypeVariant_ -> Name -> Name
genRepName GenericClass
gClass DatatypeVariant_
dv Name
name) [TyVarBndrUnit]
instTvbs

-- | A backwards-compatible synonym for 'makeFrom0'.
makeFrom :: Name -> Q Exp
makeFrom :: Name -> Q Exp
makeFrom = Name -> Q Exp
makeFrom0

-- | Generates a lambda expression which behaves like 'from'.
makeFrom0 :: Name -> Q Exp
makeFrom0 :: Name -> Q Exp
makeFrom0 = KindSigOptions -> Name -> Q Exp
makeFrom0Options KindSigOptions
defaultEmptyCaseOptions

-- | Like 'makeFrom0Options', but takes an 'EmptyCaseOptions' argument.
makeFrom0Options :: EmptyCaseOptions -> Name -> Q Exp
makeFrom0Options :: KindSigOptions -> Name -> Q Exp
makeFrom0Options = (GenericTvbs
 -> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match)
-> GenericClass -> KindSigOptions -> Name -> Q Exp
makeFunCommon GenericTvbs
-> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match
mkFrom GenericClass
Generic

-- | A backwards-compatible synonym for 'makeTo0'.
makeTo :: Name -> Q Exp
makeTo :: Name -> Q Exp
makeTo = Name -> Q Exp
makeTo0

-- | Generates a lambda expression which behaves like 'to'.
makeTo0 :: Name -> Q Exp
makeTo0 :: Name -> Q Exp
makeTo0 = KindSigOptions -> Name -> Q Exp
makeTo0Options KindSigOptions
defaultEmptyCaseOptions

-- | Like 'makeTo0Options', but takes an 'EmptyCaseOptions' argument.
makeTo0Options :: EmptyCaseOptions -> Name -> Q Exp
makeTo0Options :: KindSigOptions -> Name -> Q Exp
makeTo0Options = (GenericTvbs
 -> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match)
-> GenericClass -> KindSigOptions -> Name -> Q Exp
makeFunCommon GenericTvbs
-> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match
mkTo GenericClass
Generic

-- | Generates a lambda expression which behaves like 'from1'.
makeFrom1 :: Name -> Q Exp
makeFrom1 :: Name -> Q Exp
makeFrom1 = KindSigOptions -> Name -> Q Exp
makeFrom1Options KindSigOptions
defaultEmptyCaseOptions

-- | Like 'makeFrom1Options', but takes an 'EmptyCaseOptions' argument.
makeFrom1Options :: EmptyCaseOptions -> Name -> Q Exp
makeFrom1Options :: KindSigOptions -> Name -> Q Exp
makeFrom1Options = (GenericTvbs
 -> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match)
-> GenericClass -> KindSigOptions -> Name -> Q Exp
makeFunCommon GenericTvbs
-> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match
mkFrom GenericClass
Generic1

-- | Generates a lambda expression which behaves like 'to1'.
makeTo1 :: Name -> Q Exp
makeTo1 :: Name -> Q Exp
makeTo1 = KindSigOptions -> Name -> Q Exp
makeTo1Options KindSigOptions
defaultEmptyCaseOptions

-- | Like 'makeTo1Options', but takes an 'EmptyCaseOptions' argument.
makeTo1Options :: EmptyCaseOptions -> Name -> Q Exp
makeTo1Options :: KindSigOptions -> Name -> Q Exp
makeTo1Options = (GenericTvbs
 -> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match)
-> GenericClass -> KindSigOptions -> Name -> Q Exp
makeFunCommon GenericTvbs
-> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match
mkTo GenericClass
Generic1

makeFunCommon
  :: (GenericTvbs -> EmptyCaseOptions -> Name -> [ConstructorInfo] -> Q Match)
  -> GenericClass -> EmptyCaseOptions -> Name -> Q Exp
makeFunCommon :: (GenericTvbs
 -> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match)
-> GenericClass -> KindSigOptions -> Name -> Q Exp
makeFunCommon GenericTvbs
-> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match
maker GenericClass
gClass KindSigOptions
ecOptions Name
n = do
  i <- Name
-> Q (Either
        String (Name, [Type], [ConstructorInfo], DatatypeVariant_))
reifyDataInfo Name
n
  let (name, instTys, cons, _) = either error id i
      gt = GenericClass -> [Type] -> GenericTvbs
mkGenericTvbs GenericClass
gClass [Type]
instTys
  -- See Note [Forcing buildTypeInstance]
  buildTypeInstance gClass False name instTys
    `seq` mkCaseExp (maker gt ecOptions name cons)

genRepName :: GenericClass -> DatatypeVariant_
           -> Name -> Name
genRepName :: GenericClass -> DatatypeVariant_ -> Name -> Name
genRepName GenericClass
gClass DatatypeVariant_
dv Name
n
  = String -> Name
mkName
  (String -> Name) -> ShowS -> String -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatatypeVariant_ -> ShowS
showsDatatypeVariant DatatypeVariant_
dv
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String
"Rep" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (GenericClass -> Int
forall a. Enum a => a -> Int
fromEnum GenericClass
gClass)) String -> ShowS
forall a. [a] -> [a] -> [a]
++)
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name -> String
showNameQual Name
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_") String -> ShowS
forall a. [a] -> [a] -> [a]
++)
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
sanitizeName
  (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
n

repType :: GenericTvbs
        -> DatatypeVariant_
        -> Name
        -> TypeSubst
        -> [ConstructorInfo]
        -> Q Type
repType :: GenericTvbs
-> DatatypeVariant_
-> Name
-> TypeSubst
-> [ConstructorInfo]
-> Q Type
repType GenericTvbs
gt DatatypeVariant_
dv Name
dt TypeSubst
typeSubst [ConstructorInfo]
cs =
    Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
d1TypeName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` DatatypeVariant_ -> Name -> Q Type
mkMetaDataType DatatypeVariant_
dv Name
dt Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
      (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal Q Type -> Q Type -> Q Type
sum' (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
v1TypeName) ((ConstructorInfo -> Q Type) -> [ConstructorInfo] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (GenericTvbs
-> DatatypeVariant_
-> Name
-> TypeSubst
-> ConstructorInfo
-> Q Type
repCon GenericTvbs
gt DatatypeVariant_
dv Name
dt TypeSubst
typeSubst) [ConstructorInfo]
cs)
  where
    sum' :: Q Type -> Q Type -> Q Type
    sum' :: Q Type -> Q Type -> Q Type
sum' Q Type
a Q Type
b = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
sumTypeName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
a Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
b

repCon :: GenericTvbs
       -> DatatypeVariant_
       -> Name
       -> TypeSubst
       -> ConstructorInfo
       -> Q Type
repCon :: GenericTvbs
-> DatatypeVariant_
-> Name
-> TypeSubst
-> ConstructorInfo
-> Q Type
repCon GenericTvbs
gt DatatypeVariant_
dv Name
dt TypeSubst
typeSubst
  (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName       = Name
n
                   , constructorVars :: ConstructorInfo -> [TyVarBndrUnit]
constructorVars       = [TyVarBndrUnit]
vars
                   , constructorContext :: ConstructorInfo -> [Type]
constructorContext    = [Type]
ctxt
                   , constructorStrictness :: ConstructorInfo -> [FieldStrictness]
constructorStrictness = [FieldStrictness]
bangs
                   , constructorFields :: ConstructorInfo -> [Type]
constructorFields     = [Type]
ts
                   , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant    = ConstructorVariant
cv
                   }) = do
  Name -> [TyVarBndrUnit] -> [Type] -> Q ()
checkExistentialContext Name
n [TyVarBndrUnit]
vars [Type]
ctxt
  let mbSelNames :: Maybe [Name]
mbSelNames = case ConstructorVariant
cv of
                     ConstructorVariant
NormalConstructor          -> Maybe [Name]
forall a. Maybe a
Nothing
                     ConstructorVariant
InfixConstructor           -> Maybe [Name]
forall a. Maybe a
Nothing
                     RecordConstructor [Name]
selNames -> [Name] -> Maybe [Name]
forall a. a -> Maybe a
Just [Name]
selNames
      isRecord :: KindSigOptions
isRecord   = case ConstructorVariant
cv of
                     ConstructorVariant
NormalConstructor   -> KindSigOptions
False
                     ConstructorVariant
InfixConstructor    -> KindSigOptions
False
                     RecordConstructor [Name]
_ -> KindSigOptions
True
      isInfix :: KindSigOptions
isInfix    = case ConstructorVariant
cv of
                     ConstructorVariant
NormalConstructor   -> KindSigOptions
False
                     ConstructorVariant
InfixConstructor    -> KindSigOptions
True
                     RecordConstructor [Name]
_ -> KindSigOptions
False
  ssis <- Name -> [FieldStrictness] -> Q [SelStrictInfo]
reifySelStrictInfo Name
n [FieldStrictness]
bangs
  repConWith gt dv dt n typeSubst mbSelNames ssis ts isRecord isInfix

repConWith :: GenericTvbs
           -> DatatypeVariant_
           -> Name
           -> Name
           -> TypeSubst
           -> Maybe [Name]
           -> [SelStrictInfo]
           -> [Type]
           -> Bool
           -> Bool
           -> Q Type
repConWith :: GenericTvbs
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe [Name]
-> [SelStrictInfo]
-> [Type]
-> KindSigOptions
-> KindSigOptions
-> Q Type
repConWith GenericTvbs
gt DatatypeVariant_
dv Name
dt Name
n TypeSubst
typeSubst Maybe [Name]
mbSelNames [SelStrictInfo]
ssis [Type]
ts KindSigOptions
isRecord KindSigOptions
isInfix = do
    let structureType :: Q Type
        structureType :: Q Type
structureType = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal Q Type -> Q Type -> Q Type
prodT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
u1TypeName) [Q Type]
f

        f :: [Q Type]
        f :: [Q Type]
f = case Maybe [Name]
mbSelNames of
                 Just [Name]
selNames -> (Name -> SelStrictInfo -> Type -> Q Type)
-> [Name] -> [SelStrictInfo] -> [Type] -> [Q Type]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 (GenericTvbs
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe Name
-> SelStrictInfo
-> Type
-> Q Type
repField GenericTvbs
gt DatatypeVariant_
dv Name
dt Name
n TypeSubst
typeSubst (Maybe Name -> SelStrictInfo -> Type -> Q Type)
-> (Name -> Maybe Name) -> Name -> SelStrictInfo -> Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Maybe Name
forall a. a -> Maybe a
Just)
                                           [Name]
selNames [SelStrictInfo]
ssis [Type]
ts
                 Maybe [Name]
Nothing       -> (SelStrictInfo -> Type -> Q Type)
-> [SelStrictInfo] -> [Type] -> [Q Type]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith  (GenericTvbs
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe Name
-> SelStrictInfo
-> Type
-> Q Type
repField GenericTvbs
gt DatatypeVariant_
dv Name
dt Name
n TypeSubst
typeSubst Maybe Name
forall a. Maybe a
Nothing)
                                           [SelStrictInfo]
ssis [Type]
ts

    Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
c1TypeName
      Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` DatatypeVariant_
-> Name -> Name -> KindSigOptions -> KindSigOptions -> Q Type
mkMetaConsType DatatypeVariant_
dv Name
dt Name
n KindSigOptions
isRecord KindSigOptions
isInfix
      Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
structureType

prodT :: Q Type -> Q Type -> Q Type
prodT :: Q Type -> Q Type -> Q Type
prodT Q Type
a Q Type
b = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
productTypeName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
a Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
b

repField :: GenericTvbs
         -> DatatypeVariant_
         -> Name
         -> Name
         -> TypeSubst
         -> Maybe Name
         -> SelStrictInfo
         -> Type
         -> Q Type
repField :: GenericTvbs
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe Name
-> SelStrictInfo
-> Type
-> Q Type
repField GenericTvbs
gt DatatypeVariant_
dv Name
dt Name
ns TypeSubst
typeSubst Maybe Name
mbF SelStrictInfo
ssi Type
t =
           Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
s1TypeName
    Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` DatatypeVariant_
-> Name -> Name -> Maybe Name -> SelStrictInfo -> Q Type
mkMetaSelType DatatypeVariant_
dv Name
dt Name
ns Maybe Name
mbF SelStrictInfo
ssi
    Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (GenericTvbs -> Type -> Q Type
repFieldArg GenericTvbs
gt (Type -> Q Type) -> Q Type -> Q Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> Q Type
resolveTypeSynonyms Type
t'')
  where
    -- See Note [Generic1 is polykinded in base-4.10]
    t', t'' :: Type
    t' :: Type
t' = case GenericTvbs
gt of
              Gen1{gen1LastTvbKindVar :: GenericTvbs -> Maybe Name
gen1LastTvbKindVar = Just Name
_kvName} ->
#if MIN_VERSION_base(4,10,0)
                Type
t
#else
                substNameWithKind _kvName starK t
#endif
              GenericTvbs
_ -> Type
t
    t'' :: Type
t'' = TypeSubst -> Type -> Type
forall a. TypeSubstitution a => TypeSubst -> a -> a
applySubstitution TypeSubst
typeSubst Type
t'

repFieldArg :: GenericTvbs -> Type -> Q Type
repFieldArg :: GenericTvbs -> Type -> Q Type
repFieldArg Gen0{} Type
t = Type -> Q Type
boxT Type
t
repFieldArg (Gen1{gen1LastTvbName :: GenericTvbs -> Name
gen1LastTvbName = Name
name}) (Type -> Type
dustOff -> Type
t0) =
    Type -> Q (ArgRes Type)
go Type
t0 Q (ArgRes Type) -> (ArgRes Type -> Q Type) -> Q Type
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ArgRes Type
res -> case ArgRes Type
res of
      ArgRes Type
NoPar -> Type -> Q Type
boxT Type
t0
      ArgRes KindSigOptions
_ Type
r -> Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
r
  where
    -- | Returns NoPar if the parameter doesn't appear.
    -- Expects its argument to have been dusted.
    go :: Type -> Q (ArgRes Type)
    go :: Type -> Q (ArgRes Type)
go ForallT{} = Q (ArgRes Type)
forall a. Q a
rankNError
#if MIN_VERSION_template_haskell(2,16,0)
    go ForallVisT{} = Q (ArgRes Type)
forall a. Q a
rankNError
#endif
    go (VarT Name
t) | Name
t Name -> Name -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name
name = KindSigOptions -> Type -> ArgRes Type
forall a. KindSigOptions -> a -> ArgRes a
ArgRes KindSigOptions
True (Type -> ArgRes Type) -> Q Type -> Q (ArgRes Type)
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
par1TypeName
    go (AppT Type
f Type
x) = do
      KindSigOptions -> Q () -> Q ()
forall (f :: * -> *).
Applicative f =>
KindSigOptions -> f () -> f ()
when (KindSigOptions -> KindSigOptions
not (Type
f Type -> Name -> KindSigOptions
`ground` Name
name)) Q ()
forall a. Q a
outOfPlaceTyVarError
      mxr <- Type -> Q (ArgRes Type)
go (Type -> Type
dustOff Type
x)
      case mxr of
        ArgRes Type
NoPar -> ArgRes Type -> Q (ArgRes Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ArgRes Type
forall a. ArgRes a
NoPar
        ArgRes KindSigOptions
arg_is_param Type
xr -> do
          itf <- Type -> Q KindSigOptions
isUnsaturatedType Type
f
          when itf typeFamilyApplicationError
          ArgRes False `fmap`
            if arg_is_param
              then
                conT rec1TypeName `appT` return f
              else
                conT composeTypeName `appT` return f `appT` return xr
    go Type
_ = ArgRes Type -> Q (ArgRes Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ArgRes Type
forall a. ArgRes a
NoPar

-- | The result of checking the argument. This NoPar
-- means the parameter wasn't there. The Bool is True
-- if the argument *is* the parameter, and False otherwise.
data ArgRes a = NoPar | ArgRes !Bool a

boxT :: Type -> Q Type
boxT :: Type -> Q Type
boxT Type
ty = case Type -> Maybe (Name, Name, Name)
unboxedRepNames Type
ty of
    Just (Name
boxTyName, Name
_, Name
_) -> Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
boxTyName
    Maybe (Name, Name, Name)
Nothing                -> Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
rec0TypeName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty

mkCaseExp :: Q Match -> Q Exp
mkCaseExp :: Q Match -> Q Exp
mkCaseExp Q Match
qMatch = do
  val <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"val"
  lam1E (varP val) $ caseE (varE val) [qMatch]

mkFrom :: GenericTvbs -> EmptyCaseOptions -> Name
       -> [ConstructorInfo] -> Q Match
mkFrom :: GenericTvbs
-> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match
mkFrom GenericTvbs
gt KindSigOptions
ecOptions Name
dt [ConstructorInfo]
cs = do
    y <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"y"
    match (varP y)
          (normalB $ conE m1DataName `appE` caseE (varE y) cases)
          []
  where
    cases :: [Q Match]
cases = case [ConstructorInfo]
cs of
              [] -> KindSigOptions -> Name -> [Q Match]
errorFrom KindSigOptions
ecOptions Name
dt
              [ConstructorInfo]
_  -> (Int -> ConstructorInfo -> Q Match)
-> [Int] -> [ConstructorInfo] -> [Q Match]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericTvbs
-> (Q Exp -> Q Exp) -> Int -> Int -> ConstructorInfo -> Q Match
fromCon GenericTvbs
gt Q Exp -> Q Exp
forall a. a -> a
id ([ConstructorInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cs)) [Int
1..] [ConstructorInfo]
cs

errorFrom :: EmptyCaseOptions -> Name -> [Q Match]
errorFrom :: KindSigOptions -> Name -> [Q Match]
errorFrom KindSigOptions
useEmptyCase Name
dt
  | KindSigOptions
useEmptyCase
  = []
  | KindSigOptions
otherwise
  = [do z <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"z"
        match
          (varP z)
          (normalB $
            appE (varE seqValName) (varE z) `appE`
            appE (varE errorValName)
                 (stringE $ "No generic representation for empty datatype "
                          ++ nameBase dt))
          []]

mkTo :: GenericTvbs -> EmptyCaseOptions -> Name
     -> [ConstructorInfo] -> Q Match
mkTo :: GenericTvbs
-> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match
mkTo GenericTvbs
gt KindSigOptions
ecOptions Name
dt [ConstructorInfo]
cs = do
    y <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"y"
    match (conP m1DataName [varP y])
          (normalB $ caseE (varE y) cases)
          []
  where
    cases :: [Q Match]
cases = case [ConstructorInfo]
cs of
              [] -> KindSigOptions -> Name -> [Q Match]
errorTo KindSigOptions
ecOptions Name
dt
              [ConstructorInfo]
_  -> (Int -> ConstructorInfo -> Q Match)
-> [Int] -> [ConstructorInfo] -> [Q Match]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericTvbs
-> (Q Pat -> Q Pat) -> Int -> Int -> ConstructorInfo -> Q Match
toCon GenericTvbs
gt Q Pat -> Q Pat
forall a. a -> a
id ([ConstructorInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cs)) [Int
1..] [ConstructorInfo]
cs

errorTo :: EmptyCaseOptions -> Name -> [Q Match]
errorTo :: KindSigOptions -> Name -> [Q Match]
errorTo KindSigOptions
useEmptyCase Name
dt
  | KindSigOptions
useEmptyCase
  = []
  | KindSigOptions
otherwise
  = [do z <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"z"
        match
          (varP z)
          (normalB $
            appE (varE seqValName) (varE z) `appE`
            appE (varE errorValName)
                 (stringE $ "No values for empty datatype " ++ nameBase dt))
          []]

fromCon :: GenericTvbs -> (Q Exp -> Q Exp) -> Int -> Int
        -> ConstructorInfo -> Q Match
fromCon :: GenericTvbs
-> (Q Exp -> Q Exp) -> Int -> Int -> ConstructorInfo -> Q Match
fromCon GenericTvbs
gt Q Exp -> Q Exp
wrap Int
m Int
i
  (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
cn
                   , constructorVars :: ConstructorInfo -> [TyVarBndrUnit]
constructorVars    = [TyVarBndrUnit]
vars
                   , constructorContext :: ConstructorInfo -> [Type]
constructorContext = [Type]
ctxt
                   , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
ts
                   }) = do
  Name -> [TyVarBndrUnit] -> [Type] -> Q ()
checkExistentialContext Name
cn [TyVarBndrUnit]
vars [Type]
ctxt
  fNames <- String -> Int -> Q [Name]
newNameList String
"f" (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]
ts
  match (conP cn (map varP fNames))
        (normalB $ wrap $ lrE i m $ conE m1DataName `appE`
          foldBal prodE (conE u1DataName) (zipWith (fromField gt) fNames ts)) []

prodE :: Q Exp -> Q Exp -> Q Exp
prodE :: Q Exp -> Q Exp -> Q Exp
prodE Q Exp
x Q Exp
y = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
productDataName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
x Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
y

fromField :: GenericTvbs -> Name -> Type -> Q Exp
fromField :: GenericTvbs -> Name -> Type -> Q Exp
fromField GenericTvbs
gt Name
nr Type
t = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
m1DataName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (GenericTvbs -> Name -> Type -> Q Exp
fromFieldWrap GenericTvbs
gt Name
nr (Type -> Q Exp) -> Q Type -> Q Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> Q Type
resolveTypeSynonyms Type
t)

fromFieldWrap :: GenericTvbs -> Name -> Type -> Q Exp
fromFieldWrap :: GenericTvbs -> Name -> Type -> Q Exp
fromFieldWrap GenericTvbs
_                              Name
_  ForallT{}  = Q Exp
forall a. Q a
rankNError
fromFieldWrap GenericTvbs
gt                             Name
nr (SigT Type
t Type
_) = GenericTvbs -> Name -> Type -> Q Exp
fromFieldWrap GenericTvbs
gt Name
nr Type
t
fromFieldWrap Gen0{}                         Name
nr Type
t          = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Type -> Name
boxRepName Type
t) 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
nr
fromFieldWrap (Gen1{gen1LastTvbName :: GenericTvbs -> Name
gen1LastTvbName = Name
name}) Name
nr Type
t          = Type -> Name -> Q Exp
wC Type
t Name
name           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
nr

wC :: Type -> Name -> Q Exp
wC :: Type -> Name -> Q Exp
wC (Type -> Type
dustOff -> Type
t0) Name
name =
    Type -> Q (ArgRes Exp)
go Type
t0 Q (ArgRes Exp) -> (ArgRes Exp -> Q Exp) -> Q Exp
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ArgRes Exp
res -> case ArgRes Exp
res of
      ArgRes Exp
NoPar -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ Type -> Name
boxRepName Type
t0
      ArgRes KindSigOptions
_ Exp
r -> Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
r
  where
    -- | Returns NoPar if the parameter doesn't appear.
    -- Expects its argument to have been dusted.
    go :: Type -> Q (ArgRes Exp)
    go :: Type -> Q (ArgRes Exp)
go ForallT{} = Q (ArgRes Exp)
forall a. Q a
rankNError
#if MIN_VERSION_template_haskell(2,16,0)
    go ForallVisT{} = Q (ArgRes Exp)
forall a. Q a
rankNError
#endif
    go (VarT Name
t) | Name
t Name -> Name -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name
name = KindSigOptions -> Exp -> ArgRes Exp
forall a. KindSigOptions -> a -> ArgRes a
ArgRes KindSigOptions
True (Exp -> ArgRes Exp) -> Q Exp -> Q (ArgRes Exp)
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
par1DataName
    go (AppT Type
f Type
x) = do
      KindSigOptions -> Q () -> Q ()
forall (f :: * -> *).
Applicative f =>
KindSigOptions -> f () -> f ()
when (KindSigOptions -> KindSigOptions
not (Type
f Type -> Name -> KindSigOptions
`ground` Name
name)) Q ()
forall a. Q a
outOfPlaceTyVarError
      mxr <- Type -> Q (ArgRes Exp)
go (Type -> Type
dustOff Type
x)
      case mxr of
        ArgRes Exp
NoPar -> ArgRes Exp -> Q (ArgRes Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ArgRes Exp
forall a. ArgRes a
NoPar
        ArgRes KindSigOptions
arg_is_param Exp
xr -> do
          itf <- Type -> Q KindSigOptions
isUnsaturatedType Type
f
          when itf typeFamilyApplicationError
          ArgRes False `fmap`
            if arg_is_param
              then
                conE rec1DataName
              else
                infixApp (conE comp1DataName) (varE composeValName) (varE fmapValName `appE` return xr)
    go Type
_ = ArgRes Exp -> Q (ArgRes Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ArgRes Exp
forall a. ArgRes a
NoPar

boxRepName :: Type -> Name
boxRepName :: Type -> Name
boxRepName = Name
-> ((Name, Name, Name) -> Name) -> Maybe (Name, Name, Name) -> Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Name
k1DataName (Name, Name, Name) -> Name
forall a b c. (a, b, c) -> b
snd3 (Maybe (Name, Name, Name) -> Name)
-> (Type -> Maybe (Name, Name, Name)) -> Type -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe (Name, Name, Name)
unboxedRepNames

toCon :: GenericTvbs -> (Q Pat -> Q Pat) -> Int -> Int
      -> ConstructorInfo -> Q Match
toCon :: GenericTvbs
-> (Q Pat -> Q Pat) -> Int -> Int -> ConstructorInfo -> Q Match
toCon GenericTvbs
gt Q Pat -> Q Pat
wrap Int
m Int
i
  (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
cn
                   , constructorVars :: ConstructorInfo -> [TyVarBndrUnit]
constructorVars    = [TyVarBndrUnit]
vars
                   , constructorContext :: ConstructorInfo -> [Type]
constructorContext = [Type]
ctxt
                   , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
ts
                   }) = do
  Name -> [TyVarBndrUnit] -> [Type] -> Q ()
checkExistentialContext Name
cn [TyVarBndrUnit]
vars [Type]
ctxt
  fNames <- String -> Int -> Q [Name]
newNameList String
"f" (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]
ts
  match (wrap $ lrP i m $ conP m1DataName
          [foldBal prod (conP u1DataName []) (zipWith (toField gt) fNames ts)])
        (normalB $ foldl appE (conE cn)
                         (zipWith (\Name
nr -> Type -> Q Type
resolveTypeSynonyms (Type -> Q Type) -> (Type -> Q Exp) -> Type -> Q Exp
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> GenericTvbs -> Name -> Type -> Q Exp
toConUnwC GenericTvbs
gt Name
nr)
                         fNames ts)) []
  where prod :: m Pat -> m Pat -> m Pat
prod m Pat
x m Pat
y = Name -> [m Pat] -> m Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
productDataName [m Pat
x,m Pat
y]

toConUnwC :: GenericTvbs -> Name -> Type -> Q Exp
toConUnwC :: GenericTvbs -> Name -> Type -> Q Exp
toConUnwC Gen0{}                         Name
nr Type
_ = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
nr
toConUnwC (Gen1{gen1LastTvbName :: GenericTvbs -> Name
gen1LastTvbName = Name
name}) Name
nr Type
t = Type -> Name -> Q Exp
unwC Type
t Name
name 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
nr

toField :: GenericTvbs -> Name -> Type -> Q Pat
toField :: GenericTvbs -> Name -> Type -> Q Pat
toField GenericTvbs
gt Name
nr Type
t = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
m1DataName [GenericTvbs -> Name -> Type -> Q Pat
toFieldWrap GenericTvbs
gt Name
nr Type
t]

toFieldWrap :: GenericTvbs -> Name -> Type -> Q Pat
toFieldWrap :: GenericTvbs -> Name -> Type -> Q Pat
toFieldWrap Gen0{} Name
nr Type
t = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (Type -> Name
boxRepName Type
t) [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
nr]
toFieldWrap Gen1{} Name
nr Type
_ = Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
nr

unwC :: Type -> Name -> Q Exp
unwC :: Type -> Name -> Q Exp
unwC (Type -> Type
dustOff -> Type
t0) Name
name =
  Type -> Q (ArgRes Exp)
go Type
t0 Q (ArgRes Exp) -> (ArgRes Exp -> Q Exp) -> Q Exp
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ArgRes Exp
res -> case ArgRes Exp
res of
    ArgRes Exp
NoPar -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ Type -> Name
unboxRepName Type
t0
    ArgRes KindSigOptions
_ Exp
r -> Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
r
  where
    -- | Returns NoPar if the parameter doesn't appear.
    -- Expects its argument to have been dusted.
    go :: Type -> Q (ArgRes Exp)
    go :: Type -> Q (ArgRes Exp)
go ForallT{} = Q (ArgRes Exp)
forall a. Q a
rankNError
#if MIN_VERSION_template_haskell(2,16,0)
    go ForallVisT{} = Q (ArgRes Exp)
forall a. Q a
rankNError
#endif
    go (VarT Name
t) | Name
t Name -> Name -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name
name = KindSigOptions -> Exp -> ArgRes Exp
forall a. KindSigOptions -> a -> ArgRes a
ArgRes KindSigOptions
True (Exp -> ArgRes Exp) -> Q Exp -> Q (ArgRes Exp)
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
unPar1ValName
    go (AppT Type
f Type
x) = do
      KindSigOptions -> Q () -> Q ()
forall (f :: * -> *).
Applicative f =>
KindSigOptions -> f () -> f ()
when (KindSigOptions -> KindSigOptions
not (Type
f Type -> Name -> KindSigOptions
`ground` Name
name)) Q ()
forall a. Q a
outOfPlaceTyVarError
      mxr <- Type -> Q (ArgRes Exp)
go (Type -> Type
dustOff Type
x)
      case mxr of
        ArgRes Exp
NoPar -> ArgRes Exp -> Q (ArgRes Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ArgRes Exp
forall a. ArgRes a
NoPar
        ArgRes KindSigOptions
arg_is_param Exp
xr -> do
          itf <- Type -> Q KindSigOptions
isUnsaturatedType Type
f
          when itf typeFamilyApplicationError
          ArgRes False `fmap`
            if arg_is_param
              then
                varE unRec1ValName
              else
                infixApp (varE fmapValName `appE` return xr)
                         (varE composeValName)
                         (varE unComp1ValName)
    go Type
_ = ArgRes Exp -> Q (ArgRes Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ArgRes Exp
forall a. ArgRes a
NoPar

unboxRepName :: Type -> Name
unboxRepName :: Type -> Name
unboxRepName = Name
-> ((Name, Name, Name) -> Name) -> Maybe (Name, Name, Name) -> Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Name
unK1ValName (Name, Name, Name) -> Name
forall a b c. (a, b, c) -> c
trd3 (Maybe (Name, Name, Name) -> Name)
-> (Type -> Maybe (Name, Name, Name)) -> Type -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe (Name, Name, Name)
unboxedRepNames

lrP :: Int -> Int -> (Q Pat -> Q Pat)
lrP :: Int -> Int -> Q Pat -> Q Pat
lrP Int
i Int
n Q Pat
p
  | Int
n Int -> Int -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Int
0       = String -> Q Pat
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"lrP: impossible"
  | Int
n Int -> Int -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Int
1       = Q Pat
p
  | Int
i Int -> Int -> KindSigOptions
forall a. Ord a => a -> a -> KindSigOptions
<= Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2 = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
l1DataName [Int -> Int -> Q Pat -> Q Pat
lrP Int
i     (Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2) Q Pat
p]
  | KindSigOptions
otherwise    = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
r1DataName [Int -> Int -> Q Pat -> Q Pat
lrP (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m)     Q Pat
p]
                     where m :: Int
m = Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2

lrE :: Int -> Int -> (Q Exp -> Q Exp)
lrE :: Int -> Int -> Q Exp -> Q Exp
lrE Int
i Int
n Q Exp
e
  | Int
n Int -> Int -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Int
0       = String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"lrE: impossible"
  | Int
n Int -> Int -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Int
1       = Q Exp
e
  | Int
i Int -> Int -> KindSigOptions
forall a. Ord a => a -> a -> KindSigOptions
<= Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2 = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
l1DataName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Int -> Q Exp -> Q Exp
lrE Int
i     (Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2) Q Exp
e
  | KindSigOptions
otherwise    = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
r1DataName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Int -> Q Exp -> Q Exp
lrE (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m)     Q Exp
e
                     where m :: Int
m = Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2

unboxedRepNames :: Type -> Maybe (Name, Name, Name)
unboxedRepNames :: Type -> Maybe (Name, Name, Name)
unboxedRepNames Type
ty
  | Type
ty Type -> Type -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name -> Type
ConT Name
addrHashTypeName   = (Name, Name, Name) -> Maybe (Name, Name, Name)
forall a. a -> Maybe a
Just (Name
uAddrTypeName,   Name
uAddrDataName,   Name
uAddrHashValName)
  | Type
ty Type -> Type -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name -> Type
ConT Name
charHashTypeName   = (Name, Name, Name) -> Maybe (Name, Name, Name)
forall a. a -> Maybe a
Just (Name
uCharTypeName,   Name
uCharDataName,   Name
uCharHashValName)
  | Type
ty Type -> Type -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name -> Type
ConT Name
doubleHashTypeName = (Name, Name, Name) -> Maybe (Name, Name, Name)
forall a. a -> Maybe a
Just (Name
uDoubleTypeName, Name
uDoubleDataName, Name
uDoubleHashValName)
  | Type
ty Type -> Type -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name -> Type
ConT Name
floatHashTypeName  = (Name, Name, Name) -> Maybe (Name, Name, Name)
forall a. a -> Maybe a
Just (Name
uFloatTypeName,  Name
uFloatDataName,  Name
uFloatHashValName)
  | Type
ty Type -> Type -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name -> Type
ConT Name
intHashTypeName    = (Name, Name, Name) -> Maybe (Name, Name, Name)
forall a. a -> Maybe a
Just (Name
uIntTypeName,    Name
uIntDataName,    Name
uIntHashValName)
  | Type
ty Type -> Type -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name -> Type
ConT Name
wordHashTypeName   = (Name, Name, Name) -> Maybe (Name, Name, Name)
forall a. a -> Maybe a
Just (Name
uWordTypeName,   Name
uWordDataName,   Name
uWordHashValName)
  | KindSigOptions
otherwise                     = Maybe (Name, Name, Name)
forall a. Maybe a
Nothing

-- For the given Types, deduces the instance type (and kind) to use for a
-- Generic(1) instance. 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 :: GenericClass
                  -- ^ Generic or Generic1
                  -> KindSigOptions
                  -- ^ Whether or not to use explicit kind signatures in the instance type
                  -> Name
                  -- ^ The type constructor or data family name
                  -> [Type]
                  -- ^ The types to instantiate the instance with
                  -> Q (Type, Kind)
buildTypeInstance :: GenericClass -> KindSigOptions -> Name -> [Type] -> Q (Type, Type)
buildTypeInstance GenericClass
gClass KindSigOptions
useKindSigs Name
tyConName [Type]
varTysOrig = 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
- GenericClass -> Int
forall a. Enum a => a -> Int
fromEnum GenericClass
gClass

#if !(MIN_VERSION_base(4,10,0))
        droppedTysExp :: [Type]
        droppedTysExp = drop remainingLength varTysExp

        droppedStarKindStati :: [StarKindStatus]
        droppedStarKindStati = map canRealizeKindStar droppedTysExp
#endif

    -- Check that:
    --
    -- 1. There are enough types to drop
    --
    -- 2. If using GHC 8.0 or earlier, all types are either of kind * or kind k
    --    (for some kind variable k). See Note [Generic1 is polykinded in base-4.10].
    --
    -- If either of these checks fail, throw an error.
    when (remainingLength < 0
#if !(MIN_VERSION_base(4,10,0))
           || any (== OtherKind) droppedStarKindStati
#endif
         ) $
      derivingKindError tyConName

        -- Substitute kind * for any dropped kind variables
    let varTysExpSubst :: [Type]
-- See Note [Generic1 is polykinded in base-4.10]
#if MIN_VERSION_base(4,10,0)
        varTysExpSubst = [Type]
varTysExp
#else
        varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp

        droppedKindVarNames :: [Name]
        droppedKindVarNames = catKindVarNames droppedStarKindStati
#endif

    let remainingTysExpSubst, droppedTysExpSubst :: [Type]
        (remainingTysExpSubst, droppedTysExpSubst) =
          splitAt remainingLength varTysExpSubst

-- See Note [Generic1 is polykinded in base-4.10]
#if !(MIN_VERSION_base(4,10,0))
    -- 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 tyConName
#endif

        -- 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])
    let varTysOrigSubst :: [Type]
        varTysOrigSubst =
-- See Note [Generic1 is polykinded in base-4.10]
#if MIN_VERSION_base(4,10,0)
          [Type] -> [Type]
forall a. a -> a
id
#else
          map (substNamesWithKindStar droppedKindVarNames)
#endif
            ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ [Type]
varTysOrig

        remainingTysOrigSubst, droppedTysOrigSubst :: [Type]
        (remainingTysOrigSubst, droppedTysOrigSubst) =
            splitAt remainingLength varTysOrigSubst

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

        instanceType :: Type
        instanceType = Type -> [Type] -> Type
applyTyToTys (Name -> Type
ConT Name
tyConName) [Type]
remainingTysOrigSubst'

        -- See Note [Kind signatures in derived instances]
        instanceKind :: Kind
        instanceKind = [Type] -> Type -> Type
makeFunKind ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
typeKind [Type]
droppedTysOrigSubst) Type
starK

    -- Ensure the dropped types can be safely eta-reduced. Otherwise,
    -- throw an error.
    unless (canEtaReduce remainingTysExpSubst droppedTysExpSubst) $
      etaReductionError instanceType
    return (instanceType, instanceKind)

{-
Note [Forcing buildTypeInstance]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Sometimes, we don't explicitly need to generate a Generic(1) type instance, but
we force buildTypeInstance nevertheless. This is because it performs some checks
for whether or not the provided datatype can actually have Generic(1) implemented for
it, and produces errors if it can't. Otherwise, laziness would cause these checks
to be skipped entirely, which could result in some indecipherable type errors
down the road.

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

We generally include explicit type signatures in derived instances. One reason for
doing so is that in the case of certain data family instances, not including kind
signatures can result in ambiguity. For example, consider the following two data
family instances that are distinguished by their kinds:

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

If we dropped the kind signature for a in a derived instance for Fam a, then GHC
would have no way of knowing which instance we are talking about.

In addition to using explicit kind signatures in the instance head, we also put
explicit kinds in the associated Rep(1) instance. For example, this data type:

  data S (a :: k) = S k

Will have the following Generic1 instance generated for it:

  instance Generic1 (S :: k -> *) where
    type Rep1 (S :: k -> *) = ... (Rec0 k)

Why do we do this? Imagine what the instance would be without the explicit kind
annotation in the Rep1 instance:

  instance Generic1 S where
    type Rep1 S = ... (Rec0 k)

This is an error, since the variable k is now out-of-scope!

In the rare event that attaching explicit kind annotations does the wrong
thing, there are variants of the TH functions that allow configuring the
KindSigOptions. If KindSigOptions is set to False, then generated instances
will not include explicit kind signatures, leaving it up to GHC's kind
inference machinery to figure out the correct kinds.

Note [Generic1 is polykinded in base-4.10]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Prior to base-4.10, Generic1 :: (* -> *) -> Constraint. This means that if a Generic1
instance is defined for a polykinded data type like so:

  data Proxy k (a :: k) = Proxy

Then k is unified with *, and this has an effect on the generated Generic1 instance:

  instance Generic1 (Proxy *) where ...

We must take great care to ensure that all occurrences of k are substituted with *,
or else the generated instance will be ill kinded.

In base-4.10 and later, Generic1 :: (k -> *) -> Constraint. This means we don't have
to do any of this kind unification trickery anymore! Hooray!
-}