{-# 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
#if MIN_VERSION_base(4,9,0)
import           Generics.Deriving.TH.Post4_9
#else
import           Generics.Deriving.TH.Pre4_9
#endif

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
forall a.
(a -> a -> KindSigOptions) -> (a -> a -> KindSigOptions) -> Eq a
/= :: Options -> Options -> KindSigOptions
$c/= :: Options -> Options -> KindSigOptions
== :: Options -> Options -> KindSigOptions
$c== :: Options -> Options -> KindSigOptions
Eq, Eq 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
min :: Options -> Options -> Options
$cmin :: Options -> Options -> Options
max :: Options -> Options -> Options
$cmax :: Options -> Options -> Options
>= :: Options -> Options -> KindSigOptions
$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
compare :: Options -> Options -> Ordering
$ccompare :: Options -> Options -> Ordering
Ord, ReadPrec [Options]
ReadPrec Options
Int -> ReadS Options
ReadS [Options]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Options]
$creadListPrec :: ReadPrec [Options]
readPrec :: ReadPrec Options
$creadPrec :: ReadPrec Options
readList :: ReadS [Options]
$creadList :: ReadS [Options]
readsPrec :: Int -> ReadS Options
$creadsPrec :: Int -> ReadS Options
Read, Int -> Options -> ShowS
[Options] -> ShowS
Options -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Options] -> ShowS
$cshowList :: [Options] -> ShowS
show :: Options -> String
$cshow :: Options -> String
showsPrec :: Int -> Options -> ShowS
$cshowsPrec :: Int -> 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
forall a.
(a -> a -> KindSigOptions) -> (a -> a -> KindSigOptions) -> Eq a
/= :: RepOptions -> RepOptions -> KindSigOptions
$c/= :: RepOptions -> RepOptions -> KindSigOptions
== :: RepOptions -> RepOptions -> KindSigOptions
$c== :: RepOptions -> RepOptions -> KindSigOptions
Eq, Eq 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
min :: RepOptions -> RepOptions -> RepOptions
$cmin :: RepOptions -> RepOptions -> RepOptions
max :: RepOptions -> RepOptions -> RepOptions
$cmax :: RepOptions -> RepOptions -> RepOptions
>= :: RepOptions -> RepOptions -> KindSigOptions
$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
compare :: RepOptions -> RepOptions -> Ordering
$ccompare :: RepOptions -> RepOptions -> Ordering
Ord, ReadPrec [RepOptions]
ReadPrec RepOptions
Int -> ReadS RepOptions
ReadS [RepOptions]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RepOptions]
$creadListPrec :: ReadPrec [RepOptions]
readPrec :: ReadPrec RepOptions
$creadPrec :: ReadPrec RepOptions
readList :: ReadS [RepOptions]
$creadList :: ReadS [RepOptions]
readsPrec :: Int -> ReadS RepOptions
$creadsPrec :: Int -> ReadS RepOptions
Read, Int -> RepOptions -> ShowS
[RepOptions] -> ShowS
RepOptions -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RepOptions] -> ShowS
$cshowList :: [RepOptions] -> ShowS
show :: RepOptions -> String
$cshow :: RepOptions -> String
showsPrec :: Int -> RepOptions -> ShowS
$cshowsPrec :: Int -> 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
    [Dec]
a <- Name -> Q [Dec]
deriveMeta Name
n
    [Dec]
b <- if KindSigOptions
generic
            then GenericClass -> Options -> Name -> Q [Dec]
deriveRepresentableCommon GenericClass
Generic Options
opts Name
n
            else forall (m :: * -> *) a. Monad m => a -> m a
return []
    [Dec]
c <- if KindSigOptions
generic1
            then GenericClass -> Options -> Name -> Q [Dec]
deriveRepresentableCommon GenericClass
Generic1 Options
opts Name
n
            else forall (m :: * -> *) a. Monad m => a -> m a
return []
    forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
a forall a. [a] -> [a] -> [a]
++ [Dec]
b forall a. [a] -> [a] -> [a]
++ [Dec]
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
    [Dec]
rep  <- if Options -> RepOptions
repOptions Options
opts forall a. Eq a => a -> a -> KindSigOptions
== RepOptions
InlineRep
               then 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
    [Dec]
inst <- GenericClass -> Options -> Name -> Q [Dec]
deriveInst GenericClass
gClass Options
opts Name
n
    forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
rep forall a. [a] -> [a] -> [a]
++ [Dec]
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
  Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_)
i <- Name
-> Q (Either
        String (Name, [Type], [ConstructorInfo], DatatypeVariant_))
reifyDataInfo Name
n
  let (Name
name, [Type]
instTys, [ConstructorInfo]
cons, DatatypeVariant_
dv) = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => String -> a
error forall a. a -> a
id Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_)
i
      gt :: GenericTvbs
gt = GenericClass -> [Type] -> GenericTvbs
mkGenericTvbs GenericClass
gClass [Type]
instTys
  -- See Note [Forcing buildTypeInstance]
  !(Type, Type)
_ <- GenericClass -> KindSigOptions -> Name -> [Type] -> Q (Type, Type)
buildTypeInstance GenericClass
gClass KindSigOptions
useKindSigs Name
name [Type]
instTys

  -- See Note [Kind signatures in derived instances]
  let tySynVars :: [TyVarBndrUnit]
tySynVars  = GenericTvbs -> [TyVarBndrUnit]
genericInitTvbs GenericTvbs
gt
      tySynVars' :: [TyVarBndrUnit]
tySynVars' = if KindSigOptions
useKindSigs
                      then [TyVarBndrUnit]
tySynVars
                      else forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> TyVarBndrUnit
unKindedTV [TyVarBndrUnit]
tySynVars
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Quote m =>
Name -> [TyVarBndrUnit] -> m Type -> m Dec
tySynD (GenericClass -> DatatypeVariant_ -> Name -> Name
genRepName GenericClass
gClass DatatypeVariant_
dv Name
name)
                      (forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
changeTVFlags BndrVis
bndrReq [TyVarBndrUnit]
tySynVars')
                      (GenericTvbs
-> DatatypeVariant_
-> Name
-> TypeSubst
-> [ConstructorInfo]
-> Q Type
repType GenericTvbs
gt DatatypeVariant_
dv Name
name forall k a. Map k a
Map.empty [ConstructorInfo]
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
  Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_)
i <- Name
-> Q (Either
        String (Name, [Type], [ConstructorInfo], DatatypeVariant_))
reifyDataInfo Name
n
  let (Name
name, [Type]
instTys, [ConstructorInfo]
cons, DatatypeVariant_
dv) = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => String -> a
error forall a. a -> a
id Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_)
i
      gt :: GenericTvbs
gt = GenericClass -> [Type] -> GenericTvbs
mkGenericTvbs GenericClass
gClass [Type]
instTys
      useKindSigs :: KindSigOptions
useKindSigs = Options -> KindSigOptions
kindSigOptions Options
opts
  -- See Note [Forcing buildTypeInstance]
  !(Type
origTy, Type
origKind) <- GenericClass -> KindSigOptions -> Name -> [Type] -> Q (Type, Type)
buildTypeInstance GenericClass
gClass KindSigOptions
useKindSigs Name
name [Type]
instTys
  Type
tyInsRHS <- if Options -> RepOptions
repOptions Options
opts forall a. Eq a => a -> a -> KindSigOptions
== RepOptions
InlineRep
                 then GenericTvbs
-> DatatypeVariant_
-> Name
-> TypeSubst
-> [ConstructorInfo]
-> Q Type
repType GenericTvbs
gt DatatypeVariant_
dv Name
name forall k a. Map k a
Map.empty [ConstructorInfo]
cons
                 else GenericClass -> DatatypeVariant_ -> Name -> Type -> Q Type
makeRepTySynApp GenericClass
gClass DatatypeVariant_
dv Name
name Type
origTy

  let origSigTy :: Type
origSigTy = if KindSigOptions
useKindSigs
                     then Type -> Type -> Type
SigT Type
origTy Type
origKind
                     else Type
origTy
  Dec
tyIns <- Name -> Maybe [Q TyVarBndrUnit] -> [Q Type] -> Q Type -> DecQ
tySynInstDCompat Name
repName forall a. Maybe a
Nothing [forall (m :: * -> *) a. Monad m => a -> m a
return Type
origSigTy] (forall (m :: * -> *) a. Monad m => a -> m a
return Type
tyInsRHS)
  let ecOptions :: KindSigOptions
ecOptions = Options -> KindSigOptions
emptyCaseOptions Options
opts
      mkBody :: (GenericTvbs
 -> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match)
-> [Q Clause]
mkBody GenericTvbs
-> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match
maker = [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause []
                             (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$
                              Q Match -> Q Exp
mkCaseExp forall a b. (a -> b) -> a -> b
$
                              GenericTvbs
-> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match
maker GenericTvbs
gt KindSigOptions
ecOptions Name
name [ConstructorInfo]
cons)
                             []]
      fcs :: [Q Clause]
fcs = (GenericTvbs
 -> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match)
-> [Q Clause]
mkBody GenericTvbs
-> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match
mkFrom
      tcs :: [Q Clause]
tcs = (GenericTvbs
 -> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match)
-> [Q Clause]
mkBody GenericTvbs
-> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match
mkTo

      inline_pragmas :: [DecQ]
inline_pragmas
        | [ConstructorInfo] -> KindSigOptions
inlining_useful [ConstructorInfo]
cons
#if MIN_VERSION_template_haskell(2,7,0)
        = forall a b. (a -> b) -> [a] -> [b]
map (\Name
fun_name ->
                forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
fun_name
# if MIN_VERSION_template_haskell(2,8,0)
                         Inline
Inline RuleMatch
FunLike (Int -> Phases
FromPhase Int
1)
# else
                         (inlineSpecPhase True False True 1)
# endif
              ) [Name
fromName, Name
toName]
#else
        = [] -- Sadly, GHC 7.0 and 7.2 appear to suffer from a bug that
             -- prevents them from attaching INLINE pragmas to class methods
             -- via Template Haskell, so don't bother generating any pragmas at
             -- all for these GHC versions.
#endif
        | KindSigOptions
otherwise
        = []

  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt []) (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
genericName forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (m :: * -> *) a. Monad m => a -> m a
return Type
origSigTy)
                       ([DecQ]
inline_pragmas forall a. [a] -> [a] -> [a]
++ [forall (m :: * -> *) a. Monad m => a -> m a
return Dec
tyIns, forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
fromName [Q Clause]
fcs, forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
toName [Q Clause]
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 forall a. Ord a => a -> a -> KindSigOptions
<= Int
1  = KindSigOptions
True
      | Int
ncons forall a. Ord a => a -> a -> KindSigOptions
<= Int
4  = Int
max_fields forall a. Ord a => a -> a -> KindSigOptions
<= Int
5
      | Int
ncons forall a. Ord a => a -> a -> KindSigOptions
<= Int
8  = Int
max_fields forall a. Ord a => a -> a -> KindSigOptions
<= Int
2
      | Int
ncons forall a. Ord a => a -> a -> KindSigOptions
<= Int
16 = Int
max_fields forall a. Ord a => a -> a -> KindSigOptions
<= Int
1
      | Int
ncons forall a. Ord a => a -> a -> KindSigOptions
<= Int
24 = Int
max_fields forall a. Eq a => a -> a -> KindSigOptions
== Int
0
      | KindSigOptions
otherwise   = KindSigOptions
False
      where
        ncons :: Int
ncons      = forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cons
        max_fields :: Int
max_fields = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. Foldable t => t a -> Int
length 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
  Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_)
i <- Name
-> Q (Either
        String (Name, [Type], [ConstructorInfo], DatatypeVariant_))
reifyDataInfo Name
n
  let (Name
name, [Type]
instTys, [ConstructorInfo]
cons, DatatypeVariant_
dv) = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => String -> a
error forall a. a -> a
id Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_)
i
      gt :: GenericTvbs
gt = GenericClass -> [Type] -> GenericTvbs
mkGenericTvbs GenericClass
gClass [Type]
instTys
  -- See Note [Forcing buildTypeInstance]
  !(Type, Type)
_ <- GenericClass -> KindSigOptions -> Name -> [Type] -> Q (Type, Type)
buildTypeInstance GenericClass
gClass KindSigOptions
False Name
name [Type]
instTys

  case (Maybe (Q Type)
mbQTy, RepOptions
repOpts) of
       (Just Q Type
qTy, RepOptions
TypeSynonymRep) -> Q Type
qTy 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 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) -> forall (m :: * -> *). Quote m => Name -> m Type
conT forall a b. (a -> b) -> a -> b
$ GenericClass -> DatatypeVariant_ -> Name -> Name
genRepName GenericClass
gClass DatatypeVariant_
dv Name
name
       (Maybe (Q Type)
Nothing,  RepOptions
InlineRep)      -> 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 = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$
        forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> Name
tvName [TyVarBndrUnit]
tySynVars)
            (forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> TyVarBndrUnit
unKindedTV forall a b. (a -> b) -> a -> b
$ [Type] -> [TyVarBndrUnit]
freeVariablesWellScoped [Type
ty]
  in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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
  Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_)
i <- Name
-> Q (Either
        String (Name, [Type], [ConstructorInfo], DatatypeVariant_))
reifyDataInfo Name
n
  let (Name
name, [Type]
instTys, [ConstructorInfo]
cons, DatatypeVariant_
_) = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => String -> a
error forall a. a -> a
id Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_)
i
      gt :: GenericTvbs
gt = GenericClass -> [Type] -> GenericTvbs
mkGenericTvbs GenericClass
gClass [Type]
instTys
  -- See Note [Forcing buildTypeInstance]
  GenericClass -> KindSigOptions -> Name -> [Type] -> Q (Type, Type)
buildTypeInstance GenericClass
gClass KindSigOptions
False Name
name [Type]
instTys
    seq :: forall a b. a -> b -> b
`seq` Q Match -> Q Exp
mkCaseExp (GenericTvbs
-> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match
maker GenericTvbs
gt KindSigOptions
ecOptions Name
name [ConstructorInfo]
cons)

genRepName :: GenericClass -> DatatypeVariant_
           -> Name -> Name
genRepName :: GenericClass -> DatatypeVariant_ -> Name -> Name
genRepName GenericClass
gClass DatatypeVariant_
dv Name
n
  = String -> Name
mkName
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatatypeVariant_ -> ShowS
showsDatatypeVariant DatatypeVariant_
dv
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String
"Rep" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Enum a => a -> Int
fromEnum GenericClass
gClass)) forall a. [a] -> [a] -> [a]
++)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name -> String
showNameQual Name
n forall a. [a] -> [a] -> [a]
++ String
"_") forall a. [a] -> [a] -> [a]
++)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
sanitizeName
  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 =
    forall (m :: * -> *). Quote m => Name -> m Type
conT Name
d1TypeName forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` DatatypeVariant_ -> Name -> Q Type
mkMetaDataType DatatypeVariant_
dv Name
dt forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
      forall a. (a -> a -> a) -> a -> [a] -> a
foldBal Q Type -> Q Type -> Q Type
sum' (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
v1TypeName) (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 = forall (m :: * -> *). Quote m => Name -> m Type
conT Name
sumTypeName forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
a 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 BndrVis
checkExistentialContext Name
n [TyVarBndrUnit]
vars [Type]
ctxt
  let mbSelNames :: Maybe [Name]
mbSelNames = case ConstructorVariant
cv of
                     ConstructorVariant
NormalConstructor          -> forall a. Maybe a
Nothing
                     ConstructorVariant
InfixConstructor           -> forall a. Maybe a
Nothing
                     RecordConstructor [Name]
selNames -> 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
  [SelStrictInfo]
ssis <- Name -> [FieldStrictness] -> Q [SelStrictInfo]
reifySelStrictInfo Name
n [FieldStrictness]
bangs
  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

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 = forall a. (a -> a -> a) -> a -> [a] -> a
foldBal Q Type -> Q Type -> Q Type
prodT (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 -> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just)
                                           [Name]
selNames [SelStrictInfo]
ssis [Type]
ts
                 Maybe [Name]
Nothing       -> 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 forall a. Maybe a
Nothing)
                                           [SelStrictInfo]
ssis [Type]
ts

    forall (m :: * -> *). Quote m => Name -> m Type
conT Name
c1TypeName
      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
      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 = forall (m :: * -> *). Quote m => Name -> m Type
conT Name
productTypeName forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
a 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 =
           forall (m :: * -> *). Quote m => Name -> m Type
conT Name
s1TypeName
    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
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (GenericTvbs -> Type -> Q Type
repFieldArg GenericTvbs
gt 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'' = 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 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 -> 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{} = forall a. Q a
rankNError
#if MIN_VERSION_template_haskell(2,16,0)
    go ForallVisT{} = forall a. Q a
rankNError
#endif
    go (VarT Name
t) | Name
t forall a. Eq a => a -> a -> KindSigOptions
== Name
name = forall a. KindSigOptions -> a -> ArgRes a
ArgRes KindSigOptions
True forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *). Quote m => Name -> m Type
conT Name
par1TypeName
    go (AppT Type
f Type
x) = do
      forall (f :: * -> *).
Applicative f =>
KindSigOptions -> f BndrVis -> f BndrVis
when (KindSigOptions -> KindSigOptions
not (Type
f Type -> Name -> KindSigOptions
`ground` Name
name)) forall a. Q a
outOfPlaceTyVarError
      ArgRes Type
mxr <- Type -> Q (ArgRes Type)
go (Type -> Type
dustOff Type
x)
      case ArgRes Type
mxr of
        ArgRes Type
NoPar -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. ArgRes a
NoPar
        ArgRes KindSigOptions
arg_is_param Type
xr -> do
          KindSigOptions
itf <- Type -> Q KindSigOptions
isUnsaturatedType Type
f
          forall (f :: * -> *).
Applicative f =>
KindSigOptions -> f BndrVis -> f BndrVis
when KindSigOptions
itf forall a. Q a
typeFamilyApplicationError
          forall a. KindSigOptions -> a -> ArgRes a
ArgRes KindSigOptions
False forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
            if KindSigOptions
arg_is_param
              then
                forall (m :: * -> *). Quote m => Name -> m Type
conT Name
rec1TypeName forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (m :: * -> *) a. Monad m => a -> m a
return Type
f
              else
                forall (m :: * -> *). Quote m => Name -> m Type
conT Name
composeTypeName forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (m :: * -> *) a. Monad m => a -> m a
return Type
f forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (m :: * -> *) a. Monad m => a -> m a
return Type
xr
    go Type
_ = forall (m :: * -> *) a. Monad m => a -> m a
return 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
_) -> forall (m :: * -> *). Quote m => Name -> m Type
conT Name
boxTyName
    Maybe (Name, Name, Name)
Nothing                -> forall (m :: * -> *). Quote m => Name -> m Type
conT Name
rec0TypeName forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` 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
  Name
val <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"val"
  forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
val) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
val) [Q Match
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
    Name
y <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"y"
    forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y)
          (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
m1DataName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y) [Q Match]
cases)
          []
  where
    cases :: [Q Match]
cases = case [ConstructorInfo]
cs of
              [] -> KindSigOptions -> Name -> [Q Match]
errorFrom KindSigOptions
ecOptions Name
dt
              [ConstructorInfo]
_  -> forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericTvbs
-> (Q Exp -> Q Exp) -> Int -> Int -> ConstructorInfo -> Q Match
fromCon GenericTvbs
gt forall a. a -> a
id (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 -> KindSigOptions -> KindSigOptions
&& KindSigOptions
ghc7'8OrLater
  = []
  | KindSigOptions
otherwise
  = [do Name
z <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"z"
        forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
          (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
z)
          (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
seqValName) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
z) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
            forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
errorValName)
                 (forall (m :: * -> *). Quote m => String -> m Exp
stringE forall a b. (a -> b) -> a -> b
$ String
"No generic representation for empty datatype "
                          forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
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
    Name
y <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"y"
    forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
m1DataName [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y])
          (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y) [Q Match]
cases)
          []
  where
    cases :: [Q Match]
cases = case [ConstructorInfo]
cs of
              [] -> KindSigOptions -> Name -> [Q Match]
errorTo KindSigOptions
ecOptions Name
dt
              [ConstructorInfo]
_  -> forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericTvbs
-> (Q Pat -> Q Pat) -> Int -> Int -> ConstructorInfo -> Q Match
toCon GenericTvbs
gt forall a. a -> a
id (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 -> KindSigOptions -> KindSigOptions
&& KindSigOptions
ghc7'8OrLater
  = []
  | KindSigOptions
otherwise
  = [do Name
z <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"z"
        forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
          (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
z)
          (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
seqValName) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
z) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
            forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
errorValName)
                 (forall (m :: * -> *). Quote m => String -> m Exp
stringE forall a b. (a -> b) -> a -> b
$ String
"No values for empty datatype " forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
dt))
          []]

ghc7'8OrLater :: Bool
#if __GLASGOW_HASKELL__ >= 708
ghc7'8OrLater :: KindSigOptions
ghc7'8OrLater = KindSigOptions
True
#else
ghc7'8OrLater = False
#endif

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 BndrVis
checkExistentialContext Name
cn [TyVarBndrUnit]
vars [Type]
ctxt
  [Name]
fNames <- String -> Int -> Q [Name]
newNameList String
"f" forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts
  forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
cn (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fNames))
        (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp
wrap forall a b. (a -> b) -> a -> b
$ Int -> Int -> Q Exp -> Q Exp
lrE Int
i Int
m forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
m1DataName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
          forall a. (a -> a -> a) -> a -> [a] -> a
foldBal Q Exp -> Q Exp -> Q Exp
prodE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
u1DataName) (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericTvbs -> Name -> Type -> Q Exp
fromField GenericTvbs
gt) [Name]
fNames [Type]
ts)) []

prodE :: Q Exp -> Q Exp -> Q Exp
prodE :: Q Exp -> Q Exp -> Q Exp
prodE Q Exp
x Q Exp
y = forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
productDataName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
x 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 = forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
m1DataName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (GenericTvbs -> Name -> Type -> Q Exp
fromFieldWrap GenericTvbs
gt Name
nr 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{}  = 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          = forall (m :: * -> *). Quote m => Name -> m Exp
conE (Type -> Name
boxRepName Type
t) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` 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           forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ArgRes Exp
res -> case ArgRes Exp
res of
      ArgRes Exp
NoPar -> forall (m :: * -> *). Quote m => Name -> m Exp
conE forall a b. (a -> b) -> a -> b
$ Type -> Name
boxRepName Type
t0
      ArgRes KindSigOptions
_ Exp
r -> 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{} = forall a. Q a
rankNError
#if MIN_VERSION_template_haskell(2,16,0)
    go ForallVisT{} = forall a. Q a
rankNError
#endif
    go (VarT Name
t) | Name
t forall a. Eq a => a -> a -> KindSigOptions
== Name
name = forall a. KindSigOptions -> a -> ArgRes a
ArgRes KindSigOptions
True forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
par1DataName
    go (AppT Type
f Type
x) = do
      forall (f :: * -> *).
Applicative f =>
KindSigOptions -> f BndrVis -> f BndrVis
when (KindSigOptions -> KindSigOptions
not (Type
f Type -> Name -> KindSigOptions
`ground` Name
name)) forall a. Q a
outOfPlaceTyVarError
      ArgRes Exp
mxr <- Type -> Q (ArgRes Exp)
go (Type -> Type
dustOff Type
x)
      case ArgRes Exp
mxr of
        ArgRes Exp
NoPar -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. ArgRes a
NoPar
        ArgRes KindSigOptions
arg_is_param Exp
xr -> do
          KindSigOptions
itf <- Type -> Q KindSigOptions
isUnsaturatedType Type
f
          forall (f :: * -> *).
Applicative f =>
KindSigOptions -> f BndrVis -> f BndrVis
when KindSigOptions
itf forall a. Q a
typeFamilyApplicationError
          forall a. KindSigOptions -> a -> ArgRes a
ArgRes KindSigOptions
False forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
            if KindSigOptions
arg_is_param
              then
                forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
rec1DataName
              else
                forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
comp1DataName) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fmapValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *) a. Monad m => a -> m a
return Exp
xr)
    go Type
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. ArgRes a
NoPar

boxRepName :: Type -> Name
boxRepName :: Type -> Name
boxRepName = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Name
k1DataName forall a b c. (a, b, c) -> b
snd3 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 BndrVis
checkExistentialContext Name
cn [TyVarBndrUnit]
vars [Type]
ctxt
  [Name]
fNames <- String -> Int -> Q [Name]
newNameList String
"f" forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts
  forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Q Pat -> Q Pat
wrap forall a b. (a -> b) -> a -> b
$ Int -> Int -> Q Pat -> Q Pat
lrP Int
i Int
m forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
m1DataName
          [forall a. (a -> a -> a) -> a -> [a] -> a
foldBal forall {m :: * -> *}. Quote m => m Pat -> m Pat -> m Pat
prod (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
u1DataName []) (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericTvbs -> Name -> Type -> Q Pat
toField GenericTvbs
gt) [Name]
fNames [Type]
ts)])
        (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
cn)
                         (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Name
nr -> Type -> Q Type
resolveTypeSynonyms 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)
                         [Name]
fNames [Type]
ts)) []
  where prod :: m Pat -> m Pat -> m Pat
prod m Pat
x m Pat
y = 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
_ = 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 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` 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 = 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 = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (Type -> Name
boxRepName Type
t) [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
nr]
toFieldWrap Gen1{} Name
nr Type
_ = 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ArgRes Exp
res -> case ArgRes Exp
res of
    ArgRes Exp
NoPar -> forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ Type -> Name
unboxRepName Type
t0
    ArgRes KindSigOptions
_ Exp
r -> 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{} = forall a. Q a
rankNError
#if MIN_VERSION_template_haskell(2,16,0)
    go ForallVisT{} = forall a. Q a
rankNError
#endif
    go (VarT Name
t) | Name
t forall a. Eq a => a -> a -> KindSigOptions
== Name
name = forall a. KindSigOptions -> a -> ArgRes a
ArgRes KindSigOptions
True forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
unPar1ValName
    go (AppT Type
f Type
x) = do
      forall (f :: * -> *).
Applicative f =>
KindSigOptions -> f BndrVis -> f BndrVis
when (KindSigOptions -> KindSigOptions
not (Type
f Type -> Name -> KindSigOptions
`ground` Name
name)) forall a. Q a
outOfPlaceTyVarError
      ArgRes Exp
mxr <- Type -> Q (ArgRes Exp)
go (Type -> Type
dustOff Type
x)
      case ArgRes Exp
mxr of
        ArgRes Exp
NoPar -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. ArgRes a
NoPar
        ArgRes KindSigOptions
arg_is_param Exp
xr -> do
          KindSigOptions
itf <- Type -> Q KindSigOptions
isUnsaturatedType Type
f
          forall (f :: * -> *).
Applicative f =>
KindSigOptions -> f BndrVis -> f BndrVis
when KindSigOptions
itf forall a. Q a
typeFamilyApplicationError
          forall a. KindSigOptions -> a -> ArgRes a
ArgRes KindSigOptions
False forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
            if KindSigOptions
arg_is_param
              then
                forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
unRec1ValName
              else
                forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fmapValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *) a. Monad m => a -> m a
return Exp
xr)
                         (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName)
                         (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
unComp1ValName)
    go Type
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. ArgRes a
NoPar

unboxRepName :: Type -> Name
unboxRepName :: Type -> Name
unboxRepName = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Name
unK1ValName forall a b c. (a, b, c) -> c
trd3 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 forall a. Eq a => a -> a -> KindSigOptions
== Int
0       = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"lrP: impossible"
  | Int
n forall a. Eq a => a -> a -> KindSigOptions
== Int
1       = Q Pat
p
  | Int
i forall a. Ord a => a -> a -> KindSigOptions
<= forall a. Integral a => a -> a -> a
div Int
n Int
2 = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
l1DataName [Int -> Int -> Q Pat -> Q Pat
lrP Int
i     (forall a. Integral a => a -> a -> a
div Int
n Int
2) Q Pat
p]
  | KindSigOptions
otherwise    = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
r1DataName [Int -> Int -> Q Pat -> Q Pat
lrP (Int
iforall a. Num a => a -> a -> a
-Int
m) (Int
nforall a. Num a => a -> a -> a
-Int
m)     Q Pat
p]
                     where m :: Int
m = 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 forall a. Eq a => a -> a -> KindSigOptions
== Int
0       = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"lrE: impossible"
  | Int
n forall a. Eq a => a -> a -> KindSigOptions
== Int
1       = Q Exp
e
  | Int
i forall a. Ord a => a -> a -> KindSigOptions
<= forall a. Integral a => a -> a -> a
div Int
n Int
2 = forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
l1DataName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Int -> Q Exp -> Q Exp
lrE Int
i     (forall a. Integral a => a -> a -> a
div Int
n Int
2) Q Exp
e
  | KindSigOptions
otherwise    = forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
r1DataName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Int -> Q Exp -> Q Exp
lrE (Int
iforall a. Num a => a -> a -> a
-Int
m) (Int
nforall a. Num a => a -> a -> a
-Int
m)     Q Exp
e
                     where m :: Int
m = 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 forall a. Eq a => a -> a -> KindSigOptions
== Name -> Type
ConT Name
addrHashTypeName   = forall a. a -> Maybe a
Just (Name
uAddrTypeName,   Name
uAddrDataName,   Name
uAddrHashValName)
  | Type
ty forall a. Eq a => a -> a -> KindSigOptions
== Name -> Type
ConT Name
charHashTypeName   = forall a. a -> Maybe a
Just (Name
uCharTypeName,   Name
uCharDataName,   Name
uCharHashValName)
  | Type
ty forall a. Eq a => a -> a -> KindSigOptions
== Name -> Type
ConT Name
doubleHashTypeName = forall a. a -> Maybe a
Just (Name
uDoubleTypeName, Name
uDoubleDataName, Name
uDoubleHashValName)
  | Type
ty forall a. Eq a => a -> a -> KindSigOptions
== Name -> Type
ConT Name
floatHashTypeName  = forall a. a -> Maybe a
Just (Name
uFloatTypeName,  Name
uFloatDataName,  Name
uFloatHashValName)
  | Type
ty forall a. Eq a => a -> a -> KindSigOptions
== Name -> Type
ConT Name
intHashTypeName    = forall a. a -> Maybe a
Just (Name
uIntTypeName,    Name
uIntDataName,    Name
uIntHashValName)
  | Type
ty forall a. Eq a => a -> a -> KindSigOptions
== Name -> Type
ConT Name
wordHashTypeName   = forall a. a -> Maybe a
Just (Name
uWordTypeName,   Name
uWordDataName,   Name
uWordHashValName)
  | KindSigOptions
otherwise                     = 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.)
    [Type]
varTysExp <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms [Type]
varTysOrig

    let remainingLength :: Int
        remainingLength :: Int
remainingLength = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
varTysOrig forall a. Num a => a -> a -> a
- 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.
    forall (f :: * -> *).
Applicative f =>
KindSigOptions -> f BndrVis -> f BndrVis
when (Int
remainingLength forall a. Ord a => a -> a -> KindSigOptions
< Int
0
#if !(MIN_VERSION_base(4,10,0))
           || any (== OtherKind) droppedStarKindStati
#endif
         ) forall a b. (a -> b) -> a -> b
$
      forall a. Name -> Q a
derivingKindError Name
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]
varTysExpSubst = [Type]
varTysExp
#else
        varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp

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

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

        remainingTysOrigSubst, droppedTysOrigSubst :: [Type]
        ([Type]
remainingTysOrigSubst, [Type]
droppedTysOrigSubst) =
            forall a. Int -> [a] -> ([a], [a])
splitAt Int
remainingLength [Type]
varTysOrigSubst

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

        instanceType :: Type
        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
instanceKind = [Type] -> Type -> Type
makeFunKind (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.
    forall (f :: * -> *).
Applicative f =>
KindSigOptions -> f BndrVis -> f BndrVis
unless ([Type] -> [Type] -> KindSigOptions
canEtaReduce [Type]
remainingTysExpSubst [Type]
droppedTysExpSubst) forall a b. (a -> b) -> a -> b
$
      forall a. Type -> Q a
etaReductionError Type
instanceType
    forall (m :: * -> *) a. Monad m => a -> m a
return (Type
instanceType, Type
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!
-}