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

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

Maintainer  :  David.Feuer@gmail.com
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
$('deriveGeneric'     ''Example) -- Derives Generic instance
$('deriveGeneric1'     ''Example) -- Derives Generic1 instance
$('deriveGenericAnd1' ''Example) -- Derives Generic and Generic1 instances
@

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

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

=== General usage notes

Template Haskell imposes some fairly harsh limitations on ordering and
visibility within a module. In most cases, classes derived generically will
need to be derived using @StandaloneDeriving@ /after/ the @deriveGeneric*@
invocation. For example, if @Generically@ is a class that uses a 'GLC.Generic'
constraint for its instances, then you cannot write

@
data Fish = Fish
  deriving Show via (Generically Fish)

$(deriveGeneric 'Fish)
@

You must instead write

@
data Fish = Fish

$(deriveGeneric 'Fish)

deriving via Generically Fish
  instance Show Fish
@

Furthermore, types defined after a @deriveGeneric*@ invocation are not
visible before that invocation. This may require some careful ordering,
especially in the case of mutually recursive types. For example, the
following will not compile:

@
data Foo = Foo | Bar Baz
$(deriveGeneric 'Foo)

data Baz = Baz Int Foo
$(deriveGeneric 'Baz)
@

Instead, you must write

@
data Foo = Foo | Bar Baz
data Baz = Baz Int Foo

$(deriveGeneric 'Foo)
$(deriveGeneric 'Baz)
@
-}

-- Adapted from Generics.Regular.TH, via
-- Generics.Deriving.TH
module Generics.Linear.TH (
      deriveGeneric
    , deriveGeneric1
    , deriveGenericAnd1
  ) where

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

import           Generics.Linear.TH.Internal
import           Generics.Linear.TH.MetaData
import           Language.Haskell.TH.Datatype
import           Language.Haskell.TH.Lib
import           Language.Haskell.TH

-- Imports for splices
import           Generics.Linear.Class as GLC
  hiding ( uAddr#, uChar#, uDouble#, uFloat#, uInt#, uWord#
         , unM1, unK1, unPar1, unComp1)
import           Generics.Linear.TH.Insertions
  hiding ((.))
import qualified Generics.Linear.TH.Insertions as Ins
import           GHC.Exts (Addr#, Char#, Int#, Word#, Double#, Float#)

-- | Given the name of a type or data family constructor,
-- derive a 'GLC.Generic' instance.
deriveGeneric :: Name -> Q [Dec]
deriveGeneric :: Name -> Q [Dec]
deriveGeneric = Bool -> Bool -> Name -> Q [Dec]
deriveGenericCommon Bool
True Bool
False

-- | Given the name of a type or data family constructor,
-- derive a 'GLC.Generic1' instance.
deriveGeneric1 :: Name -> Q [Dec]
deriveGeneric1 :: Name -> Q [Dec]
deriveGeneric1 = Bool -> Bool -> Name -> Q [Dec]
deriveGenericCommon Bool
False Bool
True

-- | Given the name of a type or data family constructor,
-- derive a 'GLC.Generic' instance and a 'GLC.Generic1' instance.
deriveGenericAnd1 :: Name -> Q [Dec]
deriveGenericAnd1 :: Name -> Q [Dec]
deriveGenericAnd1 = Bool -> Bool -> Name -> Q [Dec]
deriveGenericCommon Bool
True Bool
True

deriveGenericCommon :: Bool -> Bool -> Name -> Q [Dec]
deriveGenericCommon :: Bool -> Bool -> Name -> Q [Dec]
deriveGenericCommon Bool
generic Bool
generic1 Name
n = do
    [Dec]
b <- if Bool
generic
            then GenericClass -> Name -> Q [Dec]
deriveInst GenericClass
Generic Name
n
            else forall (m :: * -> *) a. Monad m => a -> m a
return []
    [Dec]
c <- if Bool
generic1
            then GenericClass -> Name -> Q [Dec]
deriveInst GenericClass
Generic1 Name
n
            else forall (m :: * -> *) a. Monad m => a -> m a
return []
    forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
b forall a. [a] -> [a] -> [a]
++ [Dec]
c)

deriveInst :: GenericClass -> Name -> Q [Dec]
deriveInst :: GenericClass -> Name -> Q [Dec]
deriveInst GenericClass
Generic  = Name -> Name -> GenericClass -> Name -> Name -> Name -> Q [Dec]
deriveInstCommon ''Generic  ''Rep  GenericClass
Generic  'from  'to
deriveInst GenericClass
Generic1 = Name -> Name -> GenericClass -> Name -> Name -> Name -> Q [Dec]
deriveInstCommon ''Generic1 ''Rep1 GenericClass
Generic1 'from1 'to1

deriveInstCommon :: Name
                 -> Name
                 -> GenericClass
                 -> Name
                 -> Name
                 -> Name
                 -> Q [Dec]
deriveInstCommon :: Name -> Name -> GenericClass -> Name -> Name -> Name -> Q [Dec]
deriveInstCommon Name
genericName Name
repName GenericClass
gClass Name
fromName Name
toName Name
n = do
  (Name
name, [Type]
instTys, [ConstructorInfo]
cons, DatatypeVariant_
dv) <- Name -> Q (Name, [Type], [ConstructorInfo], DatatypeVariant_)
reifyDataInfo Name
n
  let gt :: GenericTvbs
gt = GenericClass -> [Type] -> GenericTvbs
mkGenericTvbs GenericClass
gClass [Type]
instTys
  (Type
origTy, Type
origKind) <- GenericClass -> Name -> [Type] -> Q (Type, Type)
buildTypeInstance GenericClass
gClass Name
name [Type]
instTys
  Type
tyInsRHS <- GenericTvbs
-> DatatypeVariant_ -> Name -> [ConstructorInfo] -> Q Type
repType GenericTvbs
gt DatatypeVariant_
dv Name
name [ConstructorInfo]
cons

  let origSigTy :: Type
origSigTy = Type -> Type -> Type
SigT Type
origTy Type
origKind
  Dec
tyIns <- Name -> Maybe [Q TyVarBndrUnit] -> [Q Type] -> Q Type -> DecQ
tySynInstDCompat Name
repName forall a. Maybe a
Nothing [forall (m :: * -> *) a. Monad m => a -> m a
return Type
origSigTy] (forall (m :: * -> *) a. Monad m => a -> m a
return Type
tyInsRHS)
  let
    mkBody :: (GenericTvbs -> [ConstructorInfo] -> Q Match) -> [Q Clause]
mkBody GenericTvbs -> [ConstructorInfo] -> Q Match
maker = [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => [m Match] -> m Exp
lamCaseE [GenericTvbs -> [ConstructorInfo] -> Q Match
maker GenericTvbs
gt [ConstructorInfo]
cons]) []]

    fcs :: [Q Clause]
fcs = (GenericTvbs -> [ConstructorInfo] -> Q Match) -> [Q Clause]
mkBody GenericTvbs -> [ConstructorInfo] -> Q Match
mkFrom
    tcs :: [Q Clause]
tcs = (GenericTvbs -> [ConstructorInfo] -> Q Match) -> [Q Clause]
mkBody GenericTvbs -> [ConstructorInfo] -> Q Match
mkTo

    inline_pragmas :: [DecQ]
inline_pragmas
      | [ConstructorInfo] -> Bool
inlining_useful [ConstructorInfo]
cons
      = forall a b. (a -> b) -> [a] -> [b]
map (\Name
fun_name -> forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
fun_name Inline
Inline RuleMatch
FunLike (Int -> Phases
FromPhase Int
1)) [Name
fromName, Name
toName]
      | Bool
otherwise
      = []
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt []) (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
genericName forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (m :: * -> *) a. Monad m => a -> m a
return Type
origSigTy)
                       ([DecQ]
inline_pragmas forall a. [a] -> [a] -> [a]
++ [forall (m :: * -> *) a. Monad m => a -> m a
return Dec
tyIns, forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
fromName [Q Clause]
fcs, forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
toName [Q Clause]
tcs])

  where
    -- Adapted from inlining_useful in GHC.Tc.Deriv.Generics.mkBindsRep in the GHC
    -- source code:
    --
    -- https://gitlab.haskell.org/ghc/ghc/-/blob/80729d96e47c99dc38e83612dfcfe01cf565eac0/compiler/GHC/Tc/Deriv/Generics.hs#L368-386
    inlining_useful :: [ConstructorInfo] -> Bool
inlining_useful [ConstructorInfo]
cons
      | Int
ncons forall a. Ord a => a -> a -> Bool
<= Int
1  = Bool
True
      | Int
ncons forall a. Ord a => a -> a -> Bool
<= Int
4  = Int
max_fields forall a. Ord a => a -> a -> Bool
<= Int
5
      | Int
ncons forall a. Ord a => a -> a -> Bool
<= Int
8  = Int
max_fields forall a. Ord a => a -> a -> Bool
<= Int
2
      | Int
ncons forall a. Ord a => a -> a -> Bool
<= Int
16 = Int
max_fields forall a. Ord a => a -> a -> Bool
<= Int
1
      | Int
ncons forall a. Ord a => a -> a -> Bool
<= Int
24 = Int
max_fields forall a. Eq a => a -> a -> Bool
== Int
0
      | Bool
otherwise   = Bool
False
      where
        ncons :: Int
ncons      = forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cons
        max_fields :: Int
max_fields = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorInfo -> [Type]
constructorFields) [ConstructorInfo]
cons

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

repCon :: GenericTvbs
       -> DatatypeVariant_
       -> Name
       -> ConstructorInfo
       -> Q Type
repCon :: GenericTvbs
-> DatatypeVariant_ -> Name -> ConstructorInfo -> Q Type
repCon GenericTvbs
gt DatatypeVariant_
dv Name
dt
  (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          -> forall a. Maybe a
Nothing
                     ConstructorVariant
InfixConstructor           -> forall a. Maybe a
Nothing
                     RecordConstructor [Name]
selNames -> forall a. a -> Maybe a
Just [Name]
selNames
      isRecord :: Bool
isRecord   = case ConstructorVariant
cv of
                     ConstructorVariant
NormalConstructor   -> Bool
False
                     ConstructorVariant
InfixConstructor    -> Bool
False
                     RecordConstructor [Name]
_ -> Bool
True
      isInfix :: Bool
isInfix    = case ConstructorVariant
cv of
                     ConstructorVariant
NormalConstructor   -> Bool
False
                     ConstructorVariant
InfixConstructor    -> Bool
True
                     RecordConstructor [Name]
_ -> Bool
False
  [SelStrictInfo]
ssis <- Name -> [FieldStrictness] -> Q [SelStrictInfo]
reifySelStrictInfo Name
n [FieldStrictness]
bangs
  GenericTvbs
-> DatatypeVariant_
-> Name
-> Name
-> Maybe [Name]
-> [SelStrictInfo]
-> [Type]
-> Bool
-> Bool
-> Q Type
repConWith GenericTvbs
gt DatatypeVariant_
dv Name
dt Name
n Maybe [Name]
mbSelNames [SelStrictInfo]
ssis [Type]
ts Bool
isRecord Bool
isInfix

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

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

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

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

repField :: GenericTvbs
         -> DatatypeVariant_
         -> Name
         -> Name
         -> Maybe Name
         -> SelStrictInfo
         -> Type
         -> Q Type
repField :: GenericTvbs
-> DatatypeVariant_
-> Name
-> Name
-> Maybe Name
-> SelStrictInfo
-> Type
-> Q Type
repField GenericTvbs
gt DatatypeVariant_
dv Name
dt Name
ns Maybe Name
mbF SelStrictInfo
ssi Type
t =
           forall (m :: * -> *). Quote m => Name -> m Type
conT ''S1
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` DatatypeVariant_
-> Name -> Name -> Maybe Name -> SelStrictInfo -> Q Type
mkMetaSelType DatatypeVariant_
dv Name
dt Name
ns Maybe Name
mbF SelStrictInfo
ssi
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (GenericTvbs -> Type -> Q Type
repFieldArg GenericTvbs
gt forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> Q Type
resolveTypeSynonyms Type
t)

repFieldArg :: GenericTvbs -> Type -> Q Type
repFieldArg :: GenericTvbs -> Type -> Q Type
repFieldArg Gen0{} (Type -> Type
dustOff -> Type
t0) = Type -> Q Type
boxT Type
t0
repFieldArg (Gen1{gen1LastTvbName :: GenericTvbs -> Name
gen1LastTvbName = Name
name}) (Type -> Type
dustOff -> Type
t0) = Q Type -> Type -> Q Type
go (forall (m :: * -> *). Quote m => Name -> m Type
conT ''Par1) Type
t0
  where
    -- | Returns NoPar if the parameter doesn't appear.
    -- Expects its argument to have been dusted.
    go :: Q Type -> Type -> Q Type
    go :: Q Type -> Type -> Q Type
go Q Type
_ ForallT{} = forall a. Q a
rankNError
    go Q Type
_ ForallVisT{} = forall a. Q a
rankNError
    go Q Type
macc (VarT Name
t) | Name
t forall a. Eq a => a -> a -> Bool
== Name
name = Q Type
macc
    go Q Type
macc (AppT Type
f Type
x) = do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Type
f Type -> Name -> Bool
`ground` Name
name)) forall a. Q a
outOfPlaceTyVarError
      let
        macc' :: Q Type
macc' = do
          Bool
itf <- Type -> Q Bool
isUnsaturatedType Type
f
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
itf forall a. Q a
typeFamilyApplicationError
          forall (m :: * -> *). Quote m => m Type -> Name -> m Type -> m Type
infixT Q Type
macc ''(:.:) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
f)
      Q Type -> Type -> Q Type
go Q Type
macc' (Type -> Type
dustOff Type
x)
    go Q Type
_ Type
_ = Type -> Q Type
boxT Type
t0

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

mkFrom :: GenericTvbs -> [ConstructorInfo] -> Q Match
mkFrom :: GenericTvbs -> [ConstructorInfo] -> Q Match
mkFrom GenericTvbs
gt [ConstructorInfo]
cs = do
    Name
y <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"y"
    forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y)
          (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE 'M1 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
tweakedCaseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y) [Q Match]
cases)
          []
  where
    cases :: [Q Match]
cases = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericTvbs
-> (Q Exp -> Q Exp) -> Int -> Int -> ConstructorInfo -> Q Match
fromCon GenericTvbs
gt forall a. a -> a
id (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cs)) [Int
1..] [ConstructorInfo]
cs

mkTo :: GenericTvbs -> [ConstructorInfo] -> Q Match
mkTo :: GenericTvbs -> [ConstructorInfo] -> Q Match
mkTo GenericTvbs
gt [ConstructorInfo]
cs = do
    Name
y <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"y"
    forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'M1 [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y])
          (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
tweakedCaseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y) [Q Match]
cases)
          []
  where
    cases :: [Q Match]
cases = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericTvbs
-> (Q Pat -> Q Pat) -> Int -> Int -> ConstructorInfo -> Q Match
toCon GenericTvbs
gt forall a. a -> a
id (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cs)) [Int
1..] [ConstructorInfo]
cs

tweakedCaseE :: Quote m => m Exp -> [m Match] -> m Exp
#if __GLASGOW_HASKELL__ >= 901
tweakedCaseE :: forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
tweakedCaseE = forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE
#else
-- In GHC 9.0.1, there was a bug in multiplicity checking of case expressions,
-- so we can't use those. Fortunately, lambda case was fine, so we just express
--
--   case scrut of
--     branches
--
-- as
--
--   (\case branches) scrut
tweakedCaseE scrut branches = lamCaseE branches `appE` scrut
#endif

fromCon :: GenericTvbs -> (Q Exp -> Q Exp) -> Int -> Int
        -> ConstructorInfo -> Q Match
fromCon :: GenericTvbs
-> (Q Exp -> Q Exp) -> Int -> Int -> ConstructorInfo -> Q Match
fromCon GenericTvbs
gt Q Exp -> Q Exp
wrap Int
m Int
i
  (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName    = Name
cn
                   , constructorVars :: ConstructorInfo -> [TyVarBndrUnit]
constructorVars    = [TyVarBndrUnit]
vars
                   , constructorContext :: ConstructorInfo -> [Type]
constructorContext = [Type]
ctxt
                   , constructorFields :: ConstructorInfo -> [Type]
constructorFields  = [Type]
ts
                   }) = do
  Name -> [TyVarBndrUnit] -> [Type] -> Q ()
checkExistentialContext Name
cn [TyVarBndrUnit]
vars [Type]
ctxt
  [Name]
fNames <- String -> Int -> Q [Name]
newNameList String
"f" forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts
  forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
cn (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fNames))
        (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp
wrap forall a b. (a -> b) -> a -> b
$ Int -> Int -> Q Exp -> Q Exp
lrE Int
i Int
m forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE 'M1 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
          forall a. (a -> a -> a) -> a -> [a] -> a
foldBal Q Exp -> Q Exp -> Q Exp
prodE (forall (m :: * -> *). Quote m => Name -> m Exp
conE 'U1) (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericTvbs -> Name -> Type -> Q Exp
fromField GenericTvbs
gt) [Name]
fNames [Type]
ts)) []

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

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

fromFieldWrap :: GenericTvbs -> Name -> Type -> Q Exp
fromFieldWrap :: GenericTvbs -> Name -> Type -> Q Exp
fromFieldWrap GenericTvbs
_                              Name
_  ForallT{}  = forall a. Q a
rankNError
fromFieldWrap GenericTvbs
gt                             Name
nr (SigT Type
t Type
_) = GenericTvbs -> Name -> Type -> Q Exp
fromFieldWrap GenericTvbs
gt Name
nr Type
t
fromFieldWrap Gen0{}                         Name
nr Type
t          = forall (m :: * -> *). Quote m => Name -> m Exp
conE (Type -> Name
boxRepName Type
t) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
nr
fromFieldWrap (Gen1{gen1LastTvbName :: GenericTvbs -> Name
gen1LastTvbName = Name
name}) Name
nr Type
t          = Type -> Name -> Q Exp
wC Type
t Name
name           forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
nr

wC :: Type -> Name -> Q Exp
wC :: Type -> Name -> Q Exp
wC (Type -> Type
dustOff -> Type
t0) Name
name = Exp -> Type -> Q Exp
go (Name -> Exp
ConE 'Par1) Type
t0
  where
    go :: Exp -> Type -> Q Exp
    go :: Exp -> Type -> Q Exp
go !Exp
_ ForallT{} = forall a. Q a
rankNError
    go Exp
_ ForallVisT{} = forall a. Q a
rankNError
    go Exp
acc (VarT Name
t) | Name
t forall a. Eq a => a -> a -> Bool
== Name
name = forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
acc
    go Exp
acc (AppT Type
_f Type
x) =
      -- We needn't check f `ground` name here; that was checked in
      -- repFieldArg.
      let
        acc' :: Exp
acc' =
          -- We needn't check for f being unsaturated; that was checked
          -- in repFieldArg.
          Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (forall a. a -> Maybe a
Just (Name -> Exp
ConE 'Comp1)) (Name -> Exp
VarE '(Ins..)) (forall a. a -> Maybe a
Just Exp
acc)
      in Exp -> Type -> Q Exp
go Exp
acc' (Type -> Type
dustOff Type
x)
    go Exp
_ Type
_ = forall (m :: * -> *). Quote m => Name -> m Exp
conE (Type -> Name
boxRepName Type
t0)

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

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

toConUnwC :: GenericTvbs -> Name -> Type -> Q Exp
toConUnwC :: GenericTvbs -> Name -> Type -> Q Exp
toConUnwC Gen0{}                         Name
nr Type
_ = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
nr
toConUnwC (Gen1{gen1LastTvbName :: GenericTvbs -> Name
gen1LastTvbName = Name
name}) Name
nr Type
t = Type -> Name -> Q Exp
unwC Type
t Name
name forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
nr

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

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

unwC :: Type -> Name -> Q Exp
unwC :: Type -> Name -> Q Exp
unwC (Type -> Type
dustOff -> Type
t0) Name
name = Exp -> Type -> Q Exp
go (Name -> Exp
VarE 'unPar1) Type
t0
  where
    go :: Exp -> Type -> Q Exp
    go :: Exp -> Type -> Q Exp
go !Exp
_ ForallT{} = forall a. Q a
rankNError
    go Exp
_ ForallVisT{} = forall a. Q a
rankNError
    go Exp
acc (VarT Name
t) | Name
t forall a. Eq a => a -> a -> Bool
== Name
name = forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
acc
    go Exp
acc (AppT Type
_f Type
x) =
      -- We needn't check f `ground` name here; that was checked in
      -- repFieldArg.
      let
        acc' :: Exp
acc' =
          -- We needn't check for f being unsaturated; that was checked
          -- in repFieldArg.
          Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (forall a. a -> Maybe a
Just Exp
acc)
                   (Name -> Exp
VarE '(Ins..))
                   (forall a. a -> Maybe a
Just (Name -> Exp
VarE 'unComp1))
      in
        Exp -> Type -> Q Exp
go Exp
acc' (Type -> Type
dustOff Type
x)
    go Exp
_ Type
_ = forall (m :: * -> *). Quote m => Name -> m Exp
varE (Type -> Name
unboxRepName Type
t0)

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

lrP :: Int -> Int -> (Q Pat -> Q Pat)
lrP :: Int -> Int -> Q Pat -> Q Pat
lrP Int
i Int
n Q Pat
p
  | Int
n forall a. Eq a => a -> a -> Bool
== Int
0       = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"lrP: impossible"
  | Int
n forall a. Eq a => a -> a -> Bool
== Int
1       = Q Pat
p
  | Int
i forall a. Ord a => a -> a -> Bool
<= forall a. Integral a => a -> a -> a
div Int
n Int
2 = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'L1 [Int -> Int -> Q Pat -> Q Pat
lrP Int
i     (forall a. Integral a => a -> a -> a
div Int
n Int
2) Q Pat
p]
  | Bool
otherwise    = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'R1 [Int -> Int -> Q Pat -> Q Pat
lrP (Int
iforall a. Num a => a -> a -> a
-Int
m) (Int
nforall a. Num a => a -> a -> a
-Int
m)     Q Pat
p]
                     where m :: Int
m = forall a. Integral a => a -> a -> a
div Int
n Int
2

lrE :: Int -> Int -> (Q Exp -> Q Exp)
lrE :: Int -> Int -> Q Exp -> Q Exp
lrE Int
i Int
n Q Exp
e
  | Int
n forall a. Eq a => a -> a -> Bool
== Int
0       = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"lrE: impossible"
  | Int
n forall a. Eq a => a -> a -> Bool
== Int
1       = Q Exp
e
  | Int
i forall a. Ord a => a -> a -> Bool
<= forall a. Integral a => a -> a -> a
div Int
n Int
2 = forall (m :: * -> *). Quote m => Name -> m Exp
conE 'L1 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Int -> Q Exp -> Q Exp
lrE Int
i     (forall a. Integral a => a -> a -> a
div Int
n Int
2) Q Exp
e
  | Bool
otherwise    = forall (m :: * -> *). Quote m => Name -> m Exp
conE 'R1 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Int -> Q Exp -> Q Exp
lrE (Int
iforall a. Num a => a -> a -> a
-Int
m) (Int
nforall a. Num a => a -> a -> a
-Int
m)     Q Exp
e
                     where m :: Int
m = forall a. Integral a => a -> a -> a
div Int
n Int
2

unboxedRepNames :: Type -> Maybe (Name, Name, Name)
unboxedRepNames :: Type -> Maybe (Name, Name, Name)
unboxedRepNames Type
ty
  | Type
ty forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''Addr#   = forall a. a -> Maybe a
Just (''UAddr,   'UAddr,   'uAddr#)
  | Type
ty forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''Char#   = forall a. a -> Maybe a
Just (''UChar,   'UChar,   'uChar#)
  | Type
ty forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''Double# = forall a. a -> Maybe a
Just (''UDouble, 'UDouble, 'uDouble#)
  | Type
ty forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''Float#  = forall a. a -> Maybe a
Just (''UFloat,  'UFloat,  'uFloat#)
  | Type
ty forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''Int#    = forall a. a -> Maybe a
Just (''UInt,    'UInt,    'uInt#)
  | Type
ty forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''Word#   = forall a. a -> Maybe a
Just (''UWord,   'UWord,   'uWord#)
  | Bool
otherwise            = forall a. Maybe a
Nothing

-- For the given Types, deduces the instance type (and kind) to use for a
-- Generic(1) instance. Coming up with the instance type isn't as simple as
-- dropping the last types, as you need to be wary of kinds being instantiated
-- with *.
-- See Note [Type inference in derived instances]
buildTypeInstance :: GenericClass
                  -- ^ Generic or Generic1
                  -> Name
                  -- ^ The type constructor or data family name
                  -> [Type]
                  -- ^ The types to instantiate the instance with
                  -> Q (Type, Kind)
buildTypeInstance :: GenericClass -> Name -> [Type] -> Q (Type, Type)
buildTypeInstance GenericClass
gClass Name
tyConName [Type]
varTysOrig = do
    -- Make sure to expand through type/kind synonyms! Otherwise, the
    -- eta-reduction check might get tripped up over type variables in a
    -- synonym that are actually dropped.
    -- (See GHC Trac #11416 for a scenario where this actually happened.)
    [Type]
varTysExp <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms [Type]
varTysOrig

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

    -- Check there are enough types to drop. If not, throw an error.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
remainingLength forall a. Ord a => a -> a -> Bool
< Int
0) forall a b. (a -> b) -> a -> b
$ forall a. Name -> Q a
derivingKindError Name
tyConName

        -- Substitute kind * for any dropped kind variables
    let varTysExpSubst :: [Type]
        varTysExpSubst :: [Type]
varTysExpSubst = [Type]
varTysExp

    let remainingTysExpSubst, droppedTysExpSubst :: [Type]
        ([Type]
remainingTysExpSubst, [Type]
droppedTysExpSubst) =
          forall a. Int -> [a] -> ([a], [a])
splitAt Int
remainingLength [Type]
varTysExpSubst

        -- 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
        remainingTysOrigSubst, droppedTysOrigSubst :: [Type]
        ([Type]
remainingTysOrigSubst, [Type]
droppedTysOrigSubst) =
            forall a. Int -> [a] -> ([a], [a])
splitAt Int
remainingLength [Type]
varTysOrig

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

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

    -- Ensure the dropped types can be safely eta-reduced. Otherwise,
    -- throw an error.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Type] -> [Type] -> Bool
canEtaReduce [Type]
remainingTysExpSubst [Type]
droppedTysExpSubst) forall a b. (a -> b) -> a -> b
$
      forall a. Type -> Q a
etaReductionError Type
instanceType
    forall (m :: * -> *) a. Monad m => a -> m a
return (Type
instanceType, Type
instanceKind)

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

We 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. The
DataFamilyKindsSpec test case checks that this behaves as intended.

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! The TypeInTypeSpec
test case checks that this behaves as intended.
-}