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

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

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

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

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

@
{-# LANGUAGE TemplateHaskell #-}

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

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

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

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

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

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

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

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

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

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

    , makeFrom0Options
    , makeTo0Options
    , makeFrom1Options
    , makeTo1Options
  ) where

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

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

import           Generics.Deriving.TH.Internal
#if MIN_VERSION_base(4,9,0)
import           Generics.Deriving.TH.Post4_9
#else
import           Generics.Deriving.TH.Pre4_9
#endif

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

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

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

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

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

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

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

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

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

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

-- | Additional options for configuring derived 'Generic'/'Generic1' instances
-- using Template Haskell.
data Options = Options
  { Options -> RepOptions
repOptions       :: RepOptions
  , Options -> KindSigOptions
kindSigOptions   :: KindSigOptions
  , Options -> KindSigOptions
emptyCaseOptions :: EmptyCaseOptions
  } deriving (Options -> Options -> KindSigOptions
(Options -> Options -> KindSigOptions)
-> (Options -> Options -> KindSigOptions) -> Eq Options
forall a.
(a -> a -> KindSigOptions) -> (a -> a -> KindSigOptions) -> Eq a
/= :: 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
      gt :: GenericTvbs
gt = GenericClass -> [Type] -> GenericTvbs
mkGenericTvbs GenericClass
gClass [Type]
instTys
  -- See Note [Forcing buildTypeInstance]
  !(Type, Type)
_ <- GenericClass -> KindSigOptions -> Name -> [Type] -> Q (Type, Type)
buildTypeInstance GenericClass
gClass KindSigOptions
useKindSigs Name
name [Type]
instTys

  -- See Note [Kind signatures in derived instances]
  let tySynVars :: [TyVarBndrUnit]
tySynVars  = GenericTvbs -> [TyVarBndrUnit]
genericInitTvbs GenericTvbs
gt
      tySynVars' :: [TyVarBndrUnit]
tySynVars' = if KindSigOptions
useKindSigs
                      then [TyVarBndrUnit]
tySynVars
                      else (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'
                      (GenericTvbs
-> DatatypeVariant_
-> Name
-> TypeSubst
-> [ConstructorInfo]
-> TypeQ
repType GenericTvbs
gt 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
      gt :: GenericTvbs
gt = GenericClass -> [Type] -> GenericTvbs
mkGenericTvbs GenericClass
gClass [Type]
instTys
      useKindSigs :: KindSigOptions
useKindSigs = Options -> KindSigOptions
kindSigOptions Options
opts
  -- See Note [Forcing buildTypeInstance]
  !(Type
origTy, Type
origKind) <- GenericClass -> KindSigOptions -> Name -> [Type] -> Q (Type, Type)
buildTypeInstance GenericClass
gClass KindSigOptions
useKindSigs Name
name [Type]
instTys
  Type
tyInsRHS <- if Options -> RepOptions
repOptions Options
opts RepOptions -> RepOptions -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== RepOptions
InlineRep
                 then GenericTvbs
-> DatatypeVariant_
-> Name
-> TypeSubst
-> [ConstructorInfo]
-> TypeQ
repType GenericTvbs
gt DatatypeVariant_
dv Name
name TypeSubst
forall k a. Map k a
Map.empty [ConstructorInfo]
cons
                 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 :: (GenericTvbs
 -> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match)
-> [ClauseQ]
mkBody GenericTvbs
-> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match
maker = [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
                             (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$
                              Q Match -> ExpQ
mkCaseExp (Q Match -> ExpQ) -> Q Match -> ExpQ
forall a b. (a -> b) -> a -> b
$
                              GenericTvbs
-> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match
maker GenericTvbs
gt KindSigOptions
ecOptions Name
name [ConstructorInfo]
cons)
                             []]
      fcs :: [ClauseQ]
fcs = (GenericTvbs
 -> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match)
-> [ClauseQ]
mkBody GenericTvbs
-> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match
mkFrom
      tcs :: [ClauseQ]
tcs = (GenericTvbs
 -> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match)
-> [ClauseQ]
mkBody GenericTvbs
-> KindSigOptions -> Name -> [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
      gt :: GenericTvbs
gt = GenericClass -> [Type] -> GenericTvbs
mkGenericTvbs GenericClass
gClass [Type]
instTys
  -- See Note [Forcing buildTypeInstance]
  !(Type, Type)
_ <- GenericClass -> KindSigOptions -> Name -> [Type] -> Q (Type, Type)
buildTypeInstance GenericClass
gClass KindSigOptions
False Name
name [Type]
instTys

  case (Maybe 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
>>= GenericTvbs
-> DatatypeVariant_ -> Name -> [ConstructorInfo] -> Type -> TypeQ
makeRepInline GenericTvbs
gt DatatypeVariant_
dv Name
name [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 :: GenericTvbs
              -> DatatypeVariant_
              -> Name
              -> [ConstructorInfo]
              -> Type
              -> Q Type
makeRepInline :: GenericTvbs
-> DatatypeVariant_ -> Name -> [ConstructorInfo] -> Type -> TypeQ
makeRepInline GenericTvbs
gt DatatypeVariant_
dv Name
name [ConstructorInfo]
cons Type
ty = do
  let instVars :: [TyVarBndrUnit]
instVars = [Type] -> [TyVarBndrUnit]
freeVariablesWellScoped [Type
ty]
      tySynVars :: [TyVarBndrUnit]
tySynVars = GenericTvbs -> [TyVarBndrUnit]
genericInitTvbs GenericTvbs
gt

      typeSubst :: TypeSubst
      typeSubst :: TypeSubst
typeSubst = [(Name, Type)] -> TypeSubst
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Type)] -> TypeSubst) -> [(Name, Type)] -> TypeSubst
forall a b. (a -> b) -> a -> b
$
        [Name] -> [Type] -> [(Name, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((TyVarBndrUnit -> Name) -> [TyVarBndrUnit] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> Name
forall flag. 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)

  GenericTvbs
-> DatatypeVariant_
-> Name
-> TypeSubst
-> [ConstructorInfo]
-> TypeQ
repType GenericTvbs
gt 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 = (GenericTvbs
 -> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match)
-> GenericClass -> KindSigOptions -> Name -> ExpQ
makeFunCommon GenericTvbs
-> KindSigOptions -> Name -> [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 = (GenericTvbs
 -> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match)
-> GenericClass -> KindSigOptions -> Name -> ExpQ
makeFunCommon GenericTvbs
-> KindSigOptions -> Name -> [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 = (GenericTvbs
 -> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match)
-> GenericClass -> KindSigOptions -> Name -> ExpQ
makeFunCommon GenericTvbs
-> KindSigOptions -> Name -> [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 = (GenericTvbs
 -> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match)
-> GenericClass -> KindSigOptions -> Name -> ExpQ
makeFunCommon GenericTvbs
-> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match
mkTo GenericClass
Generic1

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

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

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

repConWith :: GenericTvbs
           -> DatatypeVariant_
           -> Name
           -> Name
           -> TypeSubst
           -> Maybe [Name]
           -> [SelStrictInfo]
           -> [Type]
           -> Bool
           -> Bool
           -> Q Type
repConWith :: GenericTvbs
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe [Name]
-> [SelStrictInfo]
-> [Type]
-> KindSigOptions
-> KindSigOptions
-> TypeQ
repConWith GenericTvbs
gt DatatypeVariant_
dv Name
dt Name
n TypeSubst
typeSubst Maybe [Name]
mbSelNames [SelStrictInfo]
ssis [Type]
ts KindSigOptions
isRecord KindSigOptions
isInfix = do
    let structureType :: Q Type
        structureType :: 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 (GenericTvbs
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe Name
-> SelStrictInfo
-> Type
-> TypeQ
repField GenericTvbs
gt 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  (GenericTvbs
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe Name
-> SelStrictInfo
-> Type
-> TypeQ
repField GenericTvbs
gt 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 :: GenericTvbs
         -> DatatypeVariant_
         -> Name
         -> Name
         -> TypeSubst
         -> Maybe Name
         -> SelStrictInfo
         -> Type
         -> Q Type
repField :: GenericTvbs
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe Name
-> SelStrictInfo
-> Type
-> TypeQ
repField GenericTvbs
gt 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` (GenericTvbs -> Type -> TypeQ
repFieldArg GenericTvbs
gt (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 GenericTvbs
gt of
              Gen1{gen1LastTvbKindVar :: GenericTvbs -> Maybe Name
gen1LastTvbKindVar = Just Name
_kvName} ->
#if MIN_VERSION_base(4,10,0)
                Type
t
#else
                substNameWithKind _kvName starK t
#endif
              GenericTvbs
_ -> Type
t
    t'' :: Type
t'' = TypeSubst -> Type -> Type
forall a. TypeSubstitution a => TypeSubst -> a -> a
applySubstitution TypeSubst
typeSubst Type
t'

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

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

boxT :: Type -> Q Type
boxT :: Type -> 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 :: Q Match -> Q Exp
mkCaseExp :: Q Match -> ExpQ
mkCaseExp Q Match
qMatch = 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) [Q Match
qMatch]

mkFrom :: GenericTvbs -> EmptyCaseOptions -> Name
       -> [ConstructorInfo] -> Q Match
mkFrom :: GenericTvbs
-> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match
mkFrom GenericTvbs
gt KindSigOptions
ecOptions Name
dt [ConstructorInfo]
cs = do
    Name
y <- 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 (GenericTvbs
-> (ExpQ -> ExpQ) -> Int -> Int -> ConstructorInfo -> Q Match
fromCon GenericTvbs
gt ExpQ -> ExpQ
forall a. a -> a
id ([ConstructorInfo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cs)) [Int
1..] [ConstructorInfo]
cs

errorFrom :: EmptyCaseOptions -> Name -> [Q Match]
errorFrom :: KindSigOptions -> Name -> [Q Match]
errorFrom KindSigOptions
useEmptyCase Name
dt
  | KindSigOptions
useEmptyCase KindSigOptions -> 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 :: GenericTvbs -> EmptyCaseOptions -> Name
     -> [ConstructorInfo] -> Q Match
mkTo :: GenericTvbs
-> KindSigOptions -> Name -> [ConstructorInfo] -> Q Match
mkTo GenericTvbs
gt KindSigOptions
ecOptions Name
dt [ConstructorInfo]
cs = do
    Name
y <- 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 (GenericTvbs
-> (PatQ -> PatQ) -> Int -> Int -> ConstructorInfo -> Q Match
toCon GenericTvbs
gt PatQ -> PatQ
forall a. a -> a
id ([ConstructorInfo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cs)) [Int
1..] [ConstructorInfo]
cs

errorTo :: EmptyCaseOptions -> Name -> [Q Match]
errorTo :: KindSigOptions -> Name -> [Q Match]
errorTo KindSigOptions
useEmptyCase Name
dt
  | KindSigOptions
useEmptyCase KindSigOptions -> 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 :: GenericTvbs -> (Q Exp -> Q Exp) -> Int -> Int
        -> ConstructorInfo -> Q Match
fromCon :: GenericTvbs
-> (ExpQ -> ExpQ) -> Int -> Int -> ConstructorInfo -> Q Match
fromCon GenericTvbs
gt 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 (GenericTvbs -> Name -> Type -> ExpQ
fromField GenericTvbs
gt) [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 :: GenericTvbs -> Name -> Type -> Q Exp
fromField :: GenericTvbs -> Name -> Type -> ExpQ
fromField GenericTvbs
gt Name
nr Type
t = Name -> ExpQ
conE Name
m1DataName ExpQ -> ExpQ -> ExpQ
`appE` (GenericTvbs -> Name -> Type -> ExpQ
fromFieldWrap GenericTvbs
gt 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 :: GenericTvbs -> Name -> Type -> Q Exp
fromFieldWrap :: GenericTvbs -> Name -> Type -> ExpQ
fromFieldWrap GenericTvbs
_                              Name
_  ForallT{}  = ExpQ
forall a. Q a
rankNError
fromFieldWrap GenericTvbs
gt                             Name
nr (SigT Type
t Type
_) = GenericTvbs -> Name -> Type -> ExpQ
fromFieldWrap GenericTvbs
gt Name
nr Type
t
fromFieldWrap Gen0{}                         Name
nr Type
t          = Name -> ExpQ
conE (Type -> Name
boxRepName Type
t) ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
nr
fromFieldWrap (Gen1{gen1LastTvbName :: GenericTvbs -> Name
gen1LastTvbName = Name
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 (Type -> Type
dustOff -> Type
t0) Name
name =
    Type -> Q (ArgRes Exp)
go Type
t0 Q (ArgRes Exp) -> (ArgRes Exp -> ExpQ) -> ExpQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ArgRes Exp
res -> case ArgRes Exp
res of
      ArgRes Exp
NoPar -> Name -> ExpQ
conE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ Type -> Name
boxRepName Type
t0
      ArgRes KindSigOptions
_ Exp
r -> Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
r
  where
    -- | Returns NoPar if the parameter doesn't appear.
    -- Expects its argument to have been dusted.
    go :: Type -> Q (ArgRes Exp)
    go :: Type -> Q (ArgRes Exp)
go ForallT{} = Q (ArgRes Exp)
forall a. Q a
rankNError
#if MIN_VERSION_template_haskell(2,16,0)
    go ForallVisT{} = Q (ArgRes Exp)
forall a. Q a
rankNError
#endif
    go (VarT Name
t) | Name
t Name -> Name -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name
name = KindSigOptions -> Exp -> ArgRes Exp
forall a. KindSigOptions -> a -> ArgRes a
ArgRes KindSigOptions
True (Exp -> ArgRes Exp) -> ExpQ -> Q (ArgRes Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> ExpQ
conE Name
par1DataName
    go (AppT Type
f Type
x) = do
      KindSigOptions -> Q () -> Q ()
forall (f :: * -> *).
Applicative f =>
KindSigOptions -> f () -> f ()
when (KindSigOptions -> KindSigOptions
not (Type
f Type -> Name -> KindSigOptions
`ground` Name
name)) Q ()
forall a. Q a
outOfPlaceTyVarError
      ArgRes Exp
mxr <- Type -> Q (ArgRes Exp)
go (Type -> Type
dustOff Type
x)
      case ArgRes Exp
mxr of
        ArgRes Exp
NoPar -> ArgRes Exp -> Q (ArgRes Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return ArgRes Exp
forall a. ArgRes a
NoPar
        ArgRes KindSigOptions
arg_is_param Exp
xr -> do
          KindSigOptions
itf <- Type -> Q KindSigOptions
isUnsaturatedType Type
f
          KindSigOptions -> Q () -> Q ()
forall (f :: * -> *).
Applicative f =>
KindSigOptions -> f () -> f ()
when KindSigOptions
itf Q ()
forall a. Q a
typeFamilyApplicationError
          KindSigOptions -> Exp -> ArgRes Exp
forall a. KindSigOptions -> a -> ArgRes a
ArgRes KindSigOptions
False (Exp -> ArgRes Exp) -> ExpQ -> Q (ArgRes Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
            if KindSigOptions
arg_is_param
              then
                Name -> ExpQ
conE Name
rec1DataName
              else
                ExpQ -> ExpQ -> ExpQ -> ExpQ
infixApp (Name -> ExpQ
conE Name
comp1DataName) (Name -> ExpQ
varE Name
composeValName) (Name -> ExpQ
varE Name
fmapValName ExpQ -> ExpQ -> ExpQ
`appE` Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
xr)
    go Type
_ = ArgRes Exp -> Q (ArgRes Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return ArgRes Exp
forall a. ArgRes a
NoPar

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

toCon :: GenericTvbs -> (Q Pat -> Q Pat) -> Int -> Int
      -> ConstructorInfo -> Q Match
toCon :: GenericTvbs
-> (PatQ -> PatQ) -> Int -> Int -> ConstructorInfo -> Q Match
toCon GenericTvbs
gt 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 (GenericTvbs -> Name -> Type -> PatQ
toField GenericTvbs
gt) [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
>=> GenericTvbs -> Name -> Type -> ExpQ
toConUnwC GenericTvbs
gt 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 :: GenericTvbs -> Name -> Type -> Q Exp
toConUnwC :: GenericTvbs -> Name -> Type -> ExpQ
toConUnwC Gen0{}                         Name
nr Type
_ = Name -> ExpQ
varE Name
nr
toConUnwC (Gen1{gen1LastTvbName :: GenericTvbs -> Name
gen1LastTvbName = Name
name}) Name
nr Type
t = Type -> Name -> ExpQ
unwC Type
t Name
name ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
nr

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

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

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

lrP :: Int -> Int -> (Q Pat -> Q Pat)
lrP :: Int -> Int -> 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

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

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

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

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

  data S (a :: k) = S k

Will have the following Generic1 instance generated for it:

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

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

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

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

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

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

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

  data Proxy k (a :: k) = Proxy

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

  instance Generic1 (Proxy *) where ...

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

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