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

{- |
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.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).

* '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. For example, the following example will only
  compile with 'KindSigOptions' set to 'False':

  @
  newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) = Compose (f (g a))
  $('deriveAll1Options' False ''Compose)
  @

* '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.
-}

-- | 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
/= :: Options -> Options -> KindSigOptions
$c/= :: Options -> Options -> KindSigOptions
== :: Options -> Options -> KindSigOptions
$c== :: 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
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
$cp1Ord :: Eq 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
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
(Int -> Options -> ShowS)
-> (Options -> String) -> ([Options] -> ShowS) -> Show Options
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 -> KindSigOptions -> KindSigOptions -> Options
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
/= :: RepOptions -> RepOptions -> KindSigOptions
$c/= :: RepOptions -> RepOptions -> KindSigOptions
== :: RepOptions -> RepOptions -> KindSigOptions
$c== :: 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
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
$cp1Ord :: Eq 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
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
(Int -> RepOptions -> ShowS)
-> (RepOptions -> String)
-> ([RepOptions] -> ShowS)
-> Show RepOptions
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 [Dec] -> Q [Dec]
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 [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
a [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
b [Dec] -> [Dec] -> [Dec]
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 RepOptions -> RepOptions -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== RepOptions
InlineRep
               then [Dec] -> Q [Dec]
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
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
rep [Dec] -> [Dec] -> [Dec]
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) = (String -> (Name, [Type], [ConstructorInfo], DatatypeVariant_))
-> ((Name, [Type], [ConstructorInfo], DatatypeVariant_)
    -> (Name, [Type], [ConstructorInfo], DatatypeVariant_))
-> Either
     String (Name, [Type], [ConstructorInfo], DatatypeVariant_)
-> (Name, [Type], [ConstructorInfo], DatatypeVariant_)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> (Name, [Type], [ConstructorInfo], DatatypeVariant_)
forall a. HasCallStack => String -> a
error (Name, [Type], [ConstructorInfo], DatatypeVariant_)
-> (Name, [Type], [ConstructorInfo], DatatypeVariant_)
forall a. a -> a
id Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_)
i
  -- 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 ([TyVarBndrUnit]
tySynVars, GenericKind
gk) = GenericClass -> [Type] -> ([TyVarBndrUnit], GenericKind)
genericKind GenericClass
gClass [Type]
instTys
      tySynVars' :: [TyVarBndrUnit]
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
  (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Q Dec -> Q [Dec]) -> Q Dec -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Name -> [TyVarBndrUnit] -> TypeQ -> Q Dec
tySynD (GenericClass -> DatatypeVariant_ -> Name -> Name
genRepName GenericClass
gClass DatatypeVariant_
dv Name
name)
                      [TyVarBndrUnit]
tySynVars'
                      (GenericKind
-> DatatypeVariant_
-> Name
-> TypeSubst
-> [ConstructorInfo]
-> TypeQ
repType GenericKind
gk DatatypeVariant_
dv Name
name TypeSubst
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) = (String -> (Name, [Type], [ConstructorInfo], DatatypeVariant_))
-> ((Name, [Type], [ConstructorInfo], DatatypeVariant_)
    -> (Name, [Type], [ConstructorInfo], DatatypeVariant_))
-> Either
     String (Name, [Type], [ConstructorInfo], DatatypeVariant_)
-> (Name, [Type], [ConstructorInfo], DatatypeVariant_)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> (Name, [Type], [ConstructorInfo], DatatypeVariant_)
forall a. HasCallStack => String -> a
error (Name, [Type], [ConstructorInfo], DatatypeVariant_)
-> (Name, [Type], [ConstructorInfo], DatatypeVariant_)
forall a. a -> a
id Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_)
i
      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 RepOptions -> RepOptions -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== RepOptions
InlineRep
                 then GenericClass
-> DatatypeVariant_
-> Name
-> [Type]
-> [ConstructorInfo]
-> Type
-> TypeQ
makeRepInline   GenericClass
gClass DatatypeVariant_
dv Name
name [Type]
instTys [ConstructorInfo]
cons Type
origTy
                 else GenericClass -> DatatypeVariant_ -> Name -> Type -> TypeQ
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] -> [TypeQ] -> TypeQ -> Q Dec
tySynInstDCompat Name
repName Maybe [Q TyVarBndrUnit]
forall a. Maybe a
Nothing [Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
origSigTy] (Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
tyInsRHS)
  let ecOptions :: KindSigOptions
ecOptions = Options -> KindSigOptions
emptyCaseOptions Options
opts
      mkBody :: (GenericClass
 -> KindSigOptions
 -> Int
 -> Int
 -> Name
 -> [Type]
 -> [ConstructorInfo]
 -> Q Match)
-> [ClauseQ]
mkBody GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match
maker = [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$
        GenericClass
-> KindSigOptions
-> Name
-> [Type]
-> [ConstructorInfo]
-> (GenericClass
    -> KindSigOptions
    -> Int
    -> Int
    -> Name
    -> [Type]
    -> [ConstructorInfo]
    -> Q Match)
-> ExpQ
mkCaseExp GenericClass
gClass KindSigOptions
ecOptions Name
name [Type]
instTys [ConstructorInfo]
cons GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match
maker) []]
      fcs :: [ClauseQ]
fcs = (GenericClass
 -> KindSigOptions
 -> Int
 -> Int
 -> Name
 -> [Type]
 -> [ConstructorInfo]
 -> Q Match)
-> [ClauseQ]
mkBody GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match
mkFrom
      tcs :: [ClauseQ]
tcs = (GenericClass
 -> KindSigOptions
 -> Int
 -> Int
 -> Name
 -> [Type]
 -> [ConstructorInfo]
 -> Q Match)
-> [ClauseQ]
mkBody GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match
mkTo

  (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Q Dec -> Q [Dec]) -> Q Dec -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
    CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD ([TypeQ] -> CxtQ
cxt []) (Name -> TypeQ
conT Name
genericName TypeQ -> TypeQ -> TypeQ
`appT` Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
origSigTy)
                         [Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return Dec
tyIns, Name -> [ClauseQ] -> Q Dec
funD Name
fromName [ClauseQ]
fcs, Name -> [ClauseQ] -> Q Dec
funD Name
toName [ClauseQ]
tcs]

{- $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 -> TypeQ -> TypeQ
makeRep0Inline Name
n = GenericClass -> RepOptions -> Name -> Maybe TypeQ -> TypeQ
makeRepCommon GenericClass
Generic RepOptions
InlineRep Name
n (Maybe TypeQ -> TypeQ) -> (TypeQ -> Maybe TypeQ) -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeQ -> Maybe TypeQ
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 -> TypeQ -> TypeQ
makeRep1Inline Name
n = GenericClass -> RepOptions -> Name -> Maybe TypeQ -> TypeQ
makeRepCommon GenericClass
Generic1 RepOptions
InlineRep Name
n (Maybe TypeQ -> TypeQ) -> (TypeQ -> Maybe TypeQ) -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeQ -> Maybe TypeQ
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 -> TypeQ
makeRep0 Name
n = GenericClass -> RepOptions -> Name -> Maybe TypeQ -> TypeQ
makeRepCommon GenericClass
Generic RepOptions
TypeSynonymRep Name
n Maybe TypeQ
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 -> TypeQ
makeRep1 Name
n = GenericClass -> RepOptions -> Name -> Maybe TypeQ -> TypeQ
makeRepCommon GenericClass
Generic1 RepOptions
TypeSynonymRep Name
n Maybe TypeQ
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 -> TypeQ -> TypeQ
makeRep0FromType Name
n = GenericClass -> RepOptions -> Name -> Maybe TypeQ -> TypeQ
makeRepCommon GenericClass
Generic RepOptions
TypeSynonymRep Name
n (Maybe TypeQ -> TypeQ) -> (TypeQ -> Maybe TypeQ) -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeQ -> Maybe TypeQ
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 -> TypeQ -> TypeQ
makeRep1FromType Name
n = GenericClass -> RepOptions -> Name -> Maybe TypeQ -> TypeQ
makeRepCommon GenericClass
Generic1 RepOptions
TypeSynonymRep Name
n (Maybe TypeQ -> TypeQ) -> (TypeQ -> Maybe TypeQ) -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeQ -> Maybe TypeQ
forall a. a -> Maybe a
Just

makeRepCommon :: GenericClass
              -> RepOptions
              -> Name
              -> Maybe (Q Type)
              -> Q Type
makeRepCommon :: GenericClass -> RepOptions -> Name -> Maybe TypeQ -> TypeQ
makeRepCommon GenericClass
gClass RepOptions
repOpts Name
n Maybe TypeQ
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) = (String -> (Name, [Type], [ConstructorInfo], DatatypeVariant_))
-> ((Name, [Type], [ConstructorInfo], DatatypeVariant_)
    -> (Name, [Type], [ConstructorInfo], DatatypeVariant_))
-> Either
     String (Name, [Type], [ConstructorInfo], DatatypeVariant_)
-> (Name, [Type], [ConstructorInfo], DatatypeVariant_)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> (Name, [Type], [ConstructorInfo], DatatypeVariant_)
forall a. HasCallStack => String -> a
error (Name, [Type], [ConstructorInfo], DatatypeVariant_)
-> (Name, [Type], [ConstructorInfo], DatatypeVariant_)
forall a. a -> a
id Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_)
i
  -- See Note [Forcing buildTypeInstance]
  !(Type, Type)
_ <- GenericClass -> KindSigOptions -> Name -> [Type] -> Q (Type, Type)
buildTypeInstance GenericClass
gClass KindSigOptions
False Name
name [Type]
instTys

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

makeRepInline :: GenericClass
              -> DatatypeVariant_
              -> Name
              -> [Type]
              -> [ConstructorInfo]
              -> Type
              -> Q Type
makeRepInline :: GenericClass
-> DatatypeVariant_
-> Name
-> [Type]
-> [ConstructorInfo]
-> Type
-> TypeQ
makeRepInline GenericClass
gClass DatatypeVariant_
dv Name
name [Type]
instTys [ConstructorInfo]
cons Type
ty = do
  let instVars :: [TyVarBndrUnit]
instVars = [Type] -> [TyVarBndrUnit]
freeVariablesWellScoped [Type
ty]
      ([TyVarBndrUnit]
tySynVars, GenericKind
gk)  = GenericClass -> [Type] -> ([TyVarBndrUnit], GenericKind)
genericKind GenericClass
gClass [Type]
instTys

      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. TyVarBndrUnit -> 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. TyVarBndrUnit -> Name
tvName) [TyVarBndrUnit]
instVars)

  GenericKind
-> DatatypeVariant_
-> Name
-> TypeSubst
-> [ConstructorInfo]
-> TypeQ
repType GenericKind
gk DatatypeVariant_
dv Name
name TypeSubst
typeSubst [ConstructorInfo]
cons

makeRepTySynApp :: GenericClass -> DatatypeVariant_ -> Name
                -> Type -> Q Type
makeRepTySynApp :: GenericClass -> DatatypeVariant_ -> Name -> Type -> TypeQ
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 -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> TypeQ) -> Type -> TypeQ
forall a b. (a -> b) -> a -> b
$ Name -> [TyVarBndrUnit] -> Type
forall flag. Name -> [TyVarBndrUnit] -> 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 -> ExpQ
makeFrom = Name -> ExpQ
makeFrom0

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

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

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

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

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

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

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

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

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

makeFunCommon
  :: (GenericClass -> EmptyCaseOptions ->  Int -> Int -> Name -> [Type]
                   -> [ConstructorInfo] -> Q Match)
  -> GenericClass -> EmptyCaseOptions -> Name -> Q Exp
makeFunCommon :: (GenericClass
 -> KindSigOptions
 -> Int
 -> Int
 -> Name
 -> [Type]
 -> [ConstructorInfo]
 -> Q Match)
-> GenericClass -> KindSigOptions -> Name -> ExpQ
makeFunCommon GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [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_
_) = (String -> (Name, [Type], [ConstructorInfo], DatatypeVariant_))
-> ((Name, [Type], [ConstructorInfo], DatatypeVariant_)
    -> (Name, [Type], [ConstructorInfo], DatatypeVariant_))
-> Either
     String (Name, [Type], [ConstructorInfo], DatatypeVariant_)
-> (Name, [Type], [ConstructorInfo], DatatypeVariant_)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> (Name, [Type], [ConstructorInfo], DatatypeVariant_)
forall a. HasCallStack => String -> a
error (Name, [Type], [ConstructorInfo], DatatypeVariant_)
-> (Name, [Type], [ConstructorInfo], DatatypeVariant_)
forall a. a -> a
id Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_)
i
  -- See Note [Forcing buildTypeInstance]
  GenericClass -> KindSigOptions -> Name -> [Type] -> Q (Type, Type)
buildTypeInstance GenericClass
gClass KindSigOptions
False Name
name [Type]
instTys
    Q (Type, Type) -> ExpQ -> ExpQ
`seq` GenericClass
-> KindSigOptions
-> Name
-> [Type]
-> [ConstructorInfo]
-> (GenericClass
    -> KindSigOptions
    -> Int
    -> Int
    -> Name
    -> [Type]
    -> [ConstructorInfo]
    -> Q Match)
-> ExpQ
mkCaseExp GenericClass
gClass KindSigOptions
ecOptions Name
name [Type]
instTys [ConstructorInfo]
cons GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match
maker

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 :: GenericKind
        -> DatatypeVariant_
        -> Name
        -> TypeSubst
        -> [ConstructorInfo]
        -> Q Type
repType :: GenericKind
-> DatatypeVariant_
-> Name
-> TypeSubst
-> [ConstructorInfo]
-> TypeQ
repType GenericKind
gk DatatypeVariant_
dv Name
dt TypeSubst
typeSubst [ConstructorInfo]
cs =
    Name -> TypeQ
conT Name
d1TypeName TypeQ -> TypeQ -> TypeQ
`appT` DatatypeVariant_ -> Name -> TypeQ
mkMetaDataType DatatypeVariant_
dv Name
dt TypeQ -> TypeQ -> TypeQ
`appT`
      (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal TypeQ -> TypeQ -> TypeQ
sum' (Name -> TypeQ
conT Name
v1TypeName) ((ConstructorInfo -> TypeQ) -> [ConstructorInfo] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (GenericKind
-> DatatypeVariant_
-> Name
-> TypeSubst
-> ConstructorInfo
-> TypeQ
repCon GenericKind
gk DatatypeVariant_
dv Name
dt TypeSubst
typeSubst) [ConstructorInfo]
cs)
  where
    sum' :: Q Type -> Q Type -> Q Type
    sum' :: TypeQ -> TypeQ -> TypeQ
sum' TypeQ
a TypeQ
b = Name -> TypeQ
conT Name
sumTypeName TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
a TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
b

repCon :: GenericKind
       -> DatatypeVariant_
       -> Name
       -> TypeSubst
       -> ConstructorInfo
       -> Q Type
repCon :: GenericKind
-> DatatypeVariant_
-> Name
-> TypeSubst
-> ConstructorInfo
-> TypeQ
repCon GenericKind
gk 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
  [SelStrictInfo]
ssis <- Name -> [FieldStrictness] -> Q [SelStrictInfo]
reifySelStrictInfo Name
n [FieldStrictness]
bangs
  GenericKind
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe [Name]
-> [SelStrictInfo]
-> [Type]
-> KindSigOptions
-> KindSigOptions
-> TypeQ
repConWith GenericKind
gk DatatypeVariant_
dv Name
dt Name
n TypeSubst
typeSubst Maybe [Name]
mbSelNames [SelStrictInfo]
ssis [Type]
ts KindSigOptions
isRecord KindSigOptions
isInfix

repConWith :: GenericKind
           -> DatatypeVariant_
           -> Name
           -> Name
           -> TypeSubst
           -> Maybe [Name]
           -> [SelStrictInfo]
           -> [Type]
           -> Bool
           -> Bool
           -> Q Type
repConWith :: GenericKind
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe [Name]
-> [SelStrictInfo]
-> [Type]
-> KindSigOptions
-> KindSigOptions
-> TypeQ
repConWith GenericKind
gk 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 :: TypeQ
structureType = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal TypeQ -> TypeQ -> TypeQ
prodT (Name -> TypeQ
conT Name
u1TypeName) [TypeQ]
f

        f :: [Q Type]
        f :: [TypeQ]
f = case Maybe [Name]
mbSelNames of
                 Just [Name]
selNames -> (Name -> SelStrictInfo -> Type -> TypeQ)
-> [Name] -> [SelStrictInfo] -> [Type] -> [TypeQ]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 (GenericKind
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe Name
-> SelStrictInfo
-> Type
-> TypeQ
repField GenericKind
gk DatatypeVariant_
dv Name
dt Name
n TypeSubst
typeSubst (Maybe Name -> SelStrictInfo -> Type -> TypeQ)
-> (Name -> Maybe Name) -> Name -> SelStrictInfo -> Type -> TypeQ
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 -> TypeQ)
-> [SelStrictInfo] -> [Type] -> [TypeQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith  (GenericKind
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe Name
-> SelStrictInfo
-> Type
-> TypeQ
repField GenericKind
gk DatatypeVariant_
dv Name
dt Name
n TypeSubst
typeSubst Maybe Name
forall a. Maybe a
Nothing)
                                           [SelStrictInfo]
ssis [Type]
ts

    Name -> TypeQ
conT Name
c1TypeName
      TypeQ -> TypeQ -> TypeQ
`appT` DatatypeVariant_
-> Name -> Name -> KindSigOptions -> KindSigOptions -> TypeQ
mkMetaConsType DatatypeVariant_
dv Name
dt Name
n KindSigOptions
isRecord KindSigOptions
isInfix
      TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
structureType

prodT :: Q Type -> Q Type -> Q Type
prodT :: TypeQ -> TypeQ -> TypeQ
prodT TypeQ
a TypeQ
b = Name -> TypeQ
conT Name
productTypeName TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
a TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
b

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

repFieldArg :: GenericKind -> Type -> Q Type
repFieldArg :: GenericKind -> Type -> TypeQ
repFieldArg GenericKind
_ ForallT{} = TypeQ
forall a. a
rankNError
repFieldArg GenericKind
gk (SigT Type
t Type
_) = GenericKind -> Type -> TypeQ
repFieldArg GenericKind
gk Type
t
repFieldArg GenericKind
Gen0 Type
t = Type -> TypeQ
boxT Type
t
repFieldArg (Gen1 Name
name Maybe Name
_) (VarT Name
t) | Name
t Name -> Name -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name
name = Name -> TypeQ
conT Name
par1TypeName
repFieldArg gk :: GenericKind
gk@(Gen1 Name
name Maybe Name
_) Type
t = do
  let (Type
tyHead, [Type]
tyArgs)   = Type -> (Type, [Type])
unapplyTy Type
t
      numLastArgs :: Int
numLastArgs        = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyArgs
      ([Type]
lhsArgs, [Type]
rhsArgs) = Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numLastArgs) [Type]
tyArgs
      rec0Type :: TypeQ
rec0Type           = Type -> TypeQ
boxT Type
t
      phiType :: TypeQ
phiType            = Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> TypeQ) -> Type -> TypeQ
forall a b. (a -> b) -> a -> b
$ Type -> [Type] -> Type
applyTyToTys Type
tyHead [Type]
lhsArgs

      inspectTy :: Type -> Q Type
      inspectTy :: Type -> TypeQ
inspectTy (VarT Name
a)
        | Name
a Name -> Name -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name
name
        = Name -> TypeQ
conT Name
rec1TypeName TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
phiType
      inspectTy (SigT Type
ty Type
_) = Type -> TypeQ
inspectTy Type
ty
      inspectTy Type
beta
        | KindSigOptions -> KindSigOptions
not (Type -> Name -> KindSigOptions
ground Type
beta Name
name)
        = Name -> TypeQ
conT Name
composeTypeName TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
phiType
                               TypeQ -> TypeQ -> TypeQ
`appT` GenericKind -> Type -> TypeQ
repFieldArg GenericKind
gk Type
beta
      inspectTy Type
_ = TypeQ
rec0Type

  KindSigOptions
itf <- Name -> Type -> [Type] -> Q KindSigOptions
isInTypeFamilyApp Name
name Type
tyHead [Type]
tyArgs
  if (Type -> KindSigOptions) -> [Type] -> KindSigOptions
forall (t :: * -> *) a.
Foldable t =>
(a -> KindSigOptions) -> t a -> KindSigOptions
any (KindSigOptions -> KindSigOptions
not (KindSigOptions -> KindSigOptions)
-> (Type -> KindSigOptions) -> Type -> KindSigOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Name -> KindSigOptions
`ground` Name
name)) [Type]
lhsArgs KindSigOptions -> KindSigOptions -> KindSigOptions
|| KindSigOptions
itf
     then TypeQ
forall a. Q a
outOfPlaceTyVarError
     else case [Type]
rhsArgs of
          []   -> TypeQ
rec0Type
          Type
ty:[Type]
_ -> Type -> TypeQ
inspectTy Type
ty

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

mkCaseExp
  :: GenericClass -> EmptyCaseOptions -> Name -> [Type] -> [ConstructorInfo]
  -> (GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]
                   -> [ConstructorInfo] -> Q Match)
  -> Q Exp
mkCaseExp :: GenericClass
-> KindSigOptions
-> Name
-> [Type]
-> [ConstructorInfo]
-> (GenericClass
    -> KindSigOptions
    -> Int
    -> Int
    -> Name
    -> [Type]
    -> [ConstructorInfo]
    -> Q Match)
-> ExpQ
mkCaseExp GenericClass
gClass KindSigOptions
ecOptions Name
dt [Type]
instTys [ConstructorInfo]
cs GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match
matchmaker = do
  Name
val <- String -> Q Name
newName String
"val"
  PatQ -> ExpQ -> ExpQ
lam1E (Name -> PatQ
varP Name
val) (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ ExpQ -> [Q Match] -> ExpQ
caseE (Name -> ExpQ
varE Name
val) [GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match
matchmaker GenericClass
gClass KindSigOptions
ecOptions Int
1 Int
1 Name
dt [Type]
instTys [ConstructorInfo]
cs]

mkFrom :: GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]
       -> [ConstructorInfo] -> Q Match
mkFrom :: GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match
mkFrom GenericClass
gClass KindSigOptions
ecOptions Int
m Int
i Name
dt [Type]
instTys [ConstructorInfo]
cs = do
    Name
y <- String -> Q Name
newName String
"y"
    PatQ -> BodyQ -> [Q Dec] -> Q Match
match (Name -> PatQ
varP Name
y)
          (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
conE Name
m1DataName ExpQ -> ExpQ -> ExpQ
`appE` ExpQ -> [Q Match] -> ExpQ
caseE (Name -> ExpQ
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]
_  -> (Int -> ConstructorInfo -> Q Match)
-> [Int] -> [ConstructorInfo] -> [Q Match]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericKind
-> (ExpQ -> ExpQ) -> Int -> Int -> ConstructorInfo -> Q Match
fromCon GenericKind
gk ExpQ -> ExpQ
wrapE ([ConstructorInfo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cs)) [Int
1..] [ConstructorInfo]
cs
    wrapE :: ExpQ -> ExpQ
wrapE ExpQ
e = Int -> Int -> ExpQ -> ExpQ
lrE Int
i Int
m ExpQ
e
    ([TyVarBndrUnit]
_, GenericKind
gk) = GenericClass -> [Type] -> ([TyVarBndrUnit], GenericKind)
genericKind GenericClass
gClass [Type]
instTys

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 <- String -> Q Name
newName String
"z"
        PatQ -> BodyQ -> [Q Dec] -> Q Match
match
          (Name -> PatQ
varP Name
z)
          (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$
            ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
seqValName) (Name -> ExpQ
varE Name
z) ExpQ -> ExpQ -> ExpQ
`appE`
            ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
errorValName)
                 (String -> ExpQ
stringE (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ String
"No generic representation for empty datatype "
                          String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
dt))
          []]

mkTo :: GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]
     -> [ConstructorInfo] -> Q Match
mkTo :: GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match
mkTo GenericClass
gClass KindSigOptions
ecOptions Int
m Int
i Name
dt [Type]
instTys [ConstructorInfo]
cs = do
    Name
y <- String -> Q Name
newName String
"y"
    PatQ -> BodyQ -> [Q Dec] -> Q Match
match (Name -> [PatQ] -> PatQ
conP Name
m1DataName [Name -> PatQ
varP Name
y])
          (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ ExpQ -> [Q Match] -> ExpQ
caseE (Name -> ExpQ
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]
_  -> (Int -> ConstructorInfo -> Q Match)
-> [Int] -> [ConstructorInfo] -> [Q Match]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericKind
-> (PatQ -> PatQ) -> Int -> Int -> ConstructorInfo -> Q Match
toCon GenericKind
gk PatQ -> PatQ
wrapP ([ConstructorInfo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cs)) [Int
1..] [ConstructorInfo]
cs
    wrapP :: PatQ -> PatQ
wrapP PatQ
p = Int -> Int -> PatQ -> PatQ
lrP Int
i Int
m PatQ
p
    ([TyVarBndrUnit]
_, GenericKind
gk) = GenericClass -> [Type] -> ([TyVarBndrUnit], GenericKind)
genericKind GenericClass
gClass [Type]
instTys

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 <- String -> Q Name
newName String
"z"
        PatQ -> BodyQ -> [Q Dec] -> Q Match
match
          (Name -> PatQ
varP Name
z)
          (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$
            ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
seqValName) (Name -> ExpQ
varE Name
z) ExpQ -> ExpQ -> ExpQ
`appE`
            ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
errorValName)
                 (String -> ExpQ
stringE (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ String
"No values for empty datatype " String -> ShowS
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 :: GenericKind -> (Q Exp -> Q Exp) -> Int -> Int
        -> ConstructorInfo -> Q Match
fromCon :: GenericKind
-> (ExpQ -> ExpQ) -> Int -> Int -> ConstructorInfo -> Q Match
fromCon GenericKind
gk ExpQ -> ExpQ
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
  [Name]
fNames <- String -> Int -> Q [Name]
newNameList String
"f" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts
  PatQ -> BodyQ -> [Q Dec] -> Q Match
match (Name -> [PatQ] -> PatQ
conP Name
cn ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
fNames))
        (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ ExpQ -> ExpQ
wrap (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ Int -> Int -> ExpQ -> ExpQ
lrE Int
i Int
m (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
conE Name
m1DataName ExpQ -> ExpQ -> ExpQ
`appE`
          (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal ExpQ -> ExpQ -> ExpQ
prodE (Name -> ExpQ
conE Name
u1DataName) ((Name -> Type -> ExpQ) -> [Name] -> [Type] -> [ExpQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericKind -> Name -> Type -> ExpQ
fromField GenericKind
gk) [Name]
fNames [Type]
ts)) []

prodE :: Q Exp -> Q Exp -> Q Exp
prodE :: ExpQ -> ExpQ -> ExpQ
prodE ExpQ
x ExpQ
y = Name -> ExpQ
conE Name
productDataName ExpQ -> ExpQ -> ExpQ
`appE` ExpQ
x ExpQ -> ExpQ -> ExpQ
`appE` ExpQ
y

fromField :: GenericKind -> Name -> Type -> Q Exp
fromField :: GenericKind -> Name -> Type -> ExpQ
fromField GenericKind
gk Name
nr Type
t = Name -> ExpQ
conE Name
m1DataName ExpQ -> ExpQ -> ExpQ
`appE` (GenericKind -> Name -> Type -> ExpQ
fromFieldWrap GenericKind
gk Name
nr (Type -> ExpQ) -> TypeQ -> ExpQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> TypeQ
resolveTypeSynonyms Type
t)

fromFieldWrap :: GenericKind -> Name -> Type -> Q Exp
fromFieldWrap :: GenericKind -> Name -> Type -> ExpQ
fromFieldWrap GenericKind
_             Name
_  ForallT{}  = ExpQ
forall a. a
rankNError
fromFieldWrap GenericKind
gk            Name
nr (SigT Type
t Type
_) = GenericKind -> Name -> Type -> ExpQ
fromFieldWrap GenericKind
gk Name
nr Type
t
fromFieldWrap GenericKind
Gen0          Name
nr Type
t          = Name -> ExpQ
conE (Type -> Name
boxRepName Type
t) ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
nr
fromFieldWrap (Gen1 Name
name Maybe Name
_) Name
nr Type
t          = Type -> Name -> ExpQ
wC Type
t Name
name           ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
nr

wC :: Type -> Name -> Q Exp
wC :: Type -> Name -> ExpQ
wC (VarT Name
t) Name
name | Name
t Name -> Name -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name
name = Name -> ExpQ
conE Name
par1DataName
wC Type
t Name
name
  | Type -> Name -> KindSigOptions
ground Type
t Name
name = Name -> ExpQ
conE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ Type -> Name
boxRepName Type
t
  | KindSigOptions
otherwise = do
      let (Type
tyHead, [Type]
tyArgs)   = Type -> (Type, [Type])
unapplyTy Type
t
          numLastArgs :: Int
numLastArgs        = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyArgs
          ([Type]
lhsArgs, [Type]
rhsArgs) = Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numLastArgs) [Type]
tyArgs

          inspectTy :: Type -> Q Exp
          inspectTy :: Type -> ExpQ
inspectTy ForallT{} = ExpQ
forall a. a
rankNError
          inspectTy (SigT Type
ty Type
_) = Type -> ExpQ
inspectTy Type
ty
          inspectTy (VarT Name
a)
            | Name
a Name -> Name -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name
name
            = Name -> ExpQ
conE Name
rec1DataName
          inspectTy Type
beta = ExpQ -> ExpQ -> ExpQ -> ExpQ
infixApp (Name -> ExpQ
conE Name
comp1DataName)
                                    (Name -> ExpQ
varE Name
composeValName)
                                    (Name -> ExpQ
varE Name
fmapValName ExpQ -> ExpQ -> ExpQ
`appE` Type -> Name -> ExpQ
wC Type
beta Name
name)

      KindSigOptions
itf <- Name -> Type -> [Type] -> Q KindSigOptions
isInTypeFamilyApp Name
name Type
tyHead [Type]
tyArgs
      if (Type -> KindSigOptions) -> [Type] -> KindSigOptions
forall (t :: * -> *) a.
Foldable t =>
(a -> KindSigOptions) -> t a -> KindSigOptions
any (KindSigOptions -> KindSigOptions
not (KindSigOptions -> KindSigOptions)
-> (Type -> KindSigOptions) -> Type -> KindSigOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Name -> KindSigOptions
`ground` Name
name)) [Type]
lhsArgs KindSigOptions -> KindSigOptions -> KindSigOptions
|| KindSigOptions
itf
         then ExpQ
forall a. Q a
outOfPlaceTyVarError
         else case [Type]
rhsArgs of
              []   -> Name -> ExpQ
conE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ Type -> Name
boxRepName Type
t
              Type
ty:[Type]
_ -> Type -> ExpQ
inspectTy Type
ty

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 :: GenericKind -> (Q Pat -> Q Pat) -> Int -> Int
      -> ConstructorInfo -> Q Match
toCon :: GenericKind
-> (PatQ -> PatQ) -> Int -> Int -> ConstructorInfo -> Q Match
toCon GenericKind
gk PatQ -> PatQ
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
  [Name]
fNames <- String -> Int -> Q [Name]
newNameList String
"f" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts
  PatQ -> BodyQ -> [Q Dec] -> Q Match
match (PatQ -> PatQ
wrap (PatQ -> PatQ) -> PatQ -> PatQ
forall a b. (a -> b) -> a -> b
$ Int -> Int -> PatQ -> PatQ
lrP Int
i Int
m (PatQ -> PatQ) -> PatQ -> PatQ
forall a b. (a -> b) -> a -> b
$ Name -> [PatQ] -> PatQ
conP Name
m1DataName
          [(PatQ -> PatQ -> PatQ) -> PatQ -> [PatQ] -> PatQ
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal PatQ -> PatQ -> PatQ
prod (Name -> [PatQ] -> PatQ
conP Name
u1DataName []) ((Name -> Type -> PatQ) -> [Name] -> [Type] -> [PatQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericKind -> Name -> Type -> PatQ
toField GenericKind
gk) [Name]
fNames [Type]
ts)])
        (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE Name
cn)
                         ((Name -> Type -> ExpQ) -> [Name] -> [Type] -> [ExpQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Name
nr -> Type -> TypeQ
resolveTypeSynonyms (Type -> TypeQ) -> (Type -> ExpQ) -> Type -> ExpQ
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> GenericKind -> Name -> Type -> ExpQ
toConUnwC GenericKind
gk Name
nr)
                         [Name]
fNames [Type]
ts)) []
  where prod :: PatQ -> PatQ -> PatQ
prod PatQ
x PatQ
y = Name -> [PatQ] -> PatQ
conP Name
productDataName [PatQ
x,PatQ
y]

toConUnwC :: GenericKind -> Name -> Type -> Q Exp
toConUnwC :: GenericKind -> Name -> Type -> ExpQ
toConUnwC GenericKind
Gen0          Name
nr Type
_ = Name -> ExpQ
varE Name
nr
toConUnwC (Gen1 Name
name Maybe Name
_) Name
nr Type
t = Type -> Name -> ExpQ
unwC Type
t Name
name ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
nr

toField :: GenericKind -> Name -> Type -> Q Pat
toField :: GenericKind -> Name -> Type -> PatQ
toField GenericKind
gk Name
nr Type
t = Name -> [PatQ] -> PatQ
conP Name
m1DataName [GenericKind -> Name -> Type -> PatQ
toFieldWrap GenericKind
gk Name
nr Type
t]

toFieldWrap :: GenericKind -> Name -> Type -> Q Pat
toFieldWrap :: GenericKind -> Name -> Type -> PatQ
toFieldWrap GenericKind
Gen0   Name
nr Type
t = Name -> [PatQ] -> PatQ
conP (Type -> Name
boxRepName Type
t) [Name -> PatQ
varP Name
nr]
toFieldWrap Gen1{} Name
nr Type
_ = Name -> PatQ
varP Name
nr

unwC :: Type -> Name -> Q Exp
unwC :: Type -> Name -> ExpQ
unwC (SigT Type
t Type
_) Name
name = Type -> Name -> ExpQ
unwC Type
t Name
name
unwC (VarT Name
t)   Name
name | Name
t Name -> Name -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name
name = Name -> ExpQ
varE Name
unPar1ValName
unwC Type
t Name
name
  | Type -> Name -> KindSigOptions
ground Type
t Name
name = Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ Type -> Name
unboxRepName Type
t
  | KindSigOptions
otherwise = do
      let (Type
tyHead, [Type]
tyArgs)   = Type -> (Type, [Type])
unapplyTy Type
t
          numLastArgs :: Int
numLastArgs        = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyArgs
          ([Type]
lhsArgs, [Type]
rhsArgs) = Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numLastArgs) [Type]
tyArgs

          inspectTy :: Type -> Q Exp
          inspectTy :: Type -> ExpQ
inspectTy ForallT{} = ExpQ
forall a. a
rankNError
          inspectTy (SigT Type
ty Type
_) = Type -> ExpQ
inspectTy Type
ty
          inspectTy (VarT Name
a)
            | Name
a Name -> Name -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name
name
            = Name -> ExpQ
varE Name
unRec1ValName
          inspectTy Type
beta = ExpQ -> ExpQ -> ExpQ -> ExpQ
infixApp (Name -> ExpQ
varE Name
fmapValName ExpQ -> ExpQ -> ExpQ
`appE` Type -> Name -> ExpQ
unwC Type
beta Name
name)
                                    (Name -> ExpQ
varE Name
composeValName)
                                    (Name -> ExpQ
varE Name
unComp1ValName)

      KindSigOptions
itf <- Name -> Type -> [Type] -> Q KindSigOptions
isInTypeFamilyApp Name
name Type
tyHead [Type]
tyArgs
      if (Type -> KindSigOptions) -> [Type] -> KindSigOptions
forall (t :: * -> *) a.
Foldable t =>
(a -> KindSigOptions) -> t a -> KindSigOptions
any (KindSigOptions -> KindSigOptions
not (KindSigOptions -> KindSigOptions)
-> (Type -> KindSigOptions) -> Type -> KindSigOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Name -> KindSigOptions
`ground` Name
name)) [Type]
lhsArgs KindSigOptions -> KindSigOptions -> KindSigOptions
|| KindSigOptions
itf
         then ExpQ
forall a. Q a
outOfPlaceTyVarError
         else case [Type]
rhsArgs of
              []   -> Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ Type -> Name
unboxRepName Type
t
              Type
ty:[Type]
_ -> Type -> ExpQ
inspectTy Type
ty

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 -> PatQ -> PatQ
lrP Int
i Int
n PatQ
p
  | Int
n Int -> Int -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Int
0       = String -> PatQ
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       = PatQ
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 -> [PatQ] -> PatQ
conP Name
l1DataName [Int -> Int -> PatQ -> PatQ
lrP Int
i     (Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2) PatQ
p]
  | KindSigOptions
otherwise    = Name -> [PatQ] -> PatQ
conP Name
r1DataName [Int -> Int -> PatQ -> PatQ
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)     PatQ
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 -> ExpQ -> ExpQ
lrE Int
i Int
n ExpQ
e
  | Int
n Int -> Int -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Int
0       = String -> ExpQ
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       = ExpQ
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 -> ExpQ
conE Name
l1DataName ExpQ -> ExpQ -> ExpQ
`appE` Int -> Int -> ExpQ -> ExpQ
lrE Int
i     (Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2) ExpQ
e
  | KindSigOptions
otherwise    = Name -> ExpQ
conE Name
r1DataName ExpQ -> ExpQ -> ExpQ
`appE` Int -> Int -> ExpQ -> ExpQ
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)     ExpQ
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.)
    [Type]
varTysExp <- (Type -> TypeQ) -> [Type] -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TypeQ
resolveTypeSynonyms [Type]
varTysOrig

    let remainingLength :: Int
        remainingLength :: Int
remainingLength = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
varTysOrig Int -> Int -> Int
forall a. Num a => a -> a -> a
- GenericClass -> Int
forall a. Enum a => a -> Int
fromEnum GenericClass
gClass

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

        droppedStarKindStati :: [StarKindStatus]
        droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati = (Type -> StarKindStatus) -> [Type] -> [StarKindStatus]
forall a b. (a -> b) -> [a] -> [b]
map Type -> StarKindStatus
canRealizeKindStar [Type]
droppedTysExp

    -- Check there are enough types to drop and that all of them are either of
    -- kind * or kind k (for some kind variable k). If not, throw an error.
    KindSigOptions -> Q () -> Q ()
forall (f :: * -> *).
Applicative f =>
KindSigOptions -> f () -> f ()
when (Int
remainingLength Int -> Int -> KindSigOptions
forall a. Ord a => a -> a -> KindSigOptions
< Int
0 KindSigOptions -> KindSigOptions -> KindSigOptions
|| (StarKindStatus -> KindSigOptions)
-> [StarKindStatus] -> KindSigOptions
forall (t :: * -> *) a.
Foldable t =>
(a -> KindSigOptions) -> t a -> KindSigOptions
any (StarKindStatus -> StarKindStatus -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== StarKindStatus
NotKindStar) [StarKindStatus]
droppedStarKindStati) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      Name -> Q ()
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) =
          Int -> [Type] -> ([Type], [Type])
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)
          [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]
        ([Type]
remainingTysOrigSubst, [Type]
droppedTysOrigSubst) =
            Int -> [Type] -> ([Type], [Type])
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 (Type -> Type) -> [Type] -> [Type]
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 ((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.
    KindSigOptions -> Q () -> Q ()
forall (f :: * -> *).
Applicative f =>
KindSigOptions -> f () -> f ()
unless ([Type] -> [Type] -> KindSigOptions
canEtaReduce [Type]
remainingTysExpSubst [Type]
droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      Type -> Q ()
forall a. Type -> Q a
etaReductionError Type
instanceType
    (Type, Type) -> Q (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
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.

Another motivation for explicit kind signatures is the -XTypeInType extension.
With -XTypeInType, dropping kind signatures can completely change the meaning
of some data types. For example, there is a substantial difference between these
two data types:

  data T k (a :: k) = T k
  data T k a        = T k

In addition to using explicit kind signatures on type variables, we also put
explicit return kinds in the instance head, so generated instances will look
something like this:

  data S (a :: k) = S k
  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 return kind:

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

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

Although explicit kind signatures are the right thing to do in most cases, there
are sadly some degenerate cases where this isn't true. Consider this example:

  newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) = Compose (f (g a))

The Rep1 type instance in a Generic1 instance for Compose would involve the type
(f :.: Rec1 g), which forces (f :: * -> *). But this library doesn't have very
sophisticated kind inference machinery (other than what is mentioned in
Note [Generic1 is polykinded in base-4.10]), so at the moment we
have no way of actually unifying k1 with *. So the naïve generated Generic1
instance would be:

  instance Generic1 (Compose (f :: k2 -> *) (g :: k1 -> k2)) where
    type Rep1 (Compose f g) = ... (f :.: Rec1 g)

This is wrong, since f's kind is overly generalized. To get around this issue,
there are variants of the TH functions that allow you to configure 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!
-}