{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

{-
(c) The University of Glasgow 2011

-}

-- | The deriving code for the Generic class
module GHC.Tc.Deriv.Generics
   ( canDoGenerics
   , canDoGenerics1
   , GenericKind(..)
   , gen_Generic_binds
   , gen_Generic_fam_inst
   , get_gen1_constrained_tys
   )
where

import GHC.Prelude hiding (head, init, last, tail)

import GHC.Hs
import GHC.Tc.Utils.TcType
import GHC.Tc.Deriv.Generate
import GHC.Tc.Deriv.Functor
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Instantiate( newFamInst )
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Monad

import GHC.Core.Type
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom )

import GHC.Unit.Module ( moduleName, moduleUnit
                       , unitFS, getModule )

import GHC.Iface.Env    ( newGlobalBinder )

import GHC.Types.Name hiding ( varName )
import GHC.Types.Name.Reader
import GHC.Types.SourceText
import GHC.Types.Fixity
import GHC.Types.Basic
import GHC.Types.SrcLoc
import GHC.Types.Var.Env
import GHC.Types.Var.Set (elemVarSet)

import GHC.Builtin.Types.Prim
import GHC.Builtin.Types
import GHC.Builtin.Names

import GHC.Utils.Error( Validity'(..), andValid )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc

import GHC.Driver.DynFlags
import GHC.Data.FastString

import Language.Haskell.Syntax.Basic (FieldLabelString(..))

import Control.Monad (mplus)
import Data.List (zip4, partition)
import qualified Data.List as Partial (last)
import Data.List.NonEmpty (nonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.Maybe (isJust)

{-
************************************************************************
*                                                                      *
\subsection{Bindings for the new generic deriving mechanism}
*                                                                      *
************************************************************************

For the generic representation we need to generate:
\begin{itemize}
\item A Generic instance
\item A Rep type instance
\item Many auxiliary datatypes and instances for them (for the meta-information)
\end{itemize}
-}

gen_Generic_binds :: GenericKind -> SrcSpan -> DerivInstTys
                  -> TcM (LHsBinds GhcPs, [LSig GhcPs])
gen_Generic_binds :: GenericKind
-> SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, [LSig GhcPs])
gen_Generic_binds GenericKind
gk SrcSpan
loc DerivInstTys
dit = do
  dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  return $ mkBindsRep dflags gk loc dit

{-
************************************************************************
*                                                                      *
\subsection{Generating representation types}
*                                                                      *
************************************************************************
-}

-- | Called by 'GHC.Tc.Deriv.Infer.inferConstraints'; generates a list of
-- types, each of which must be a 'Functor' in order for the 'Generic1'
-- instance to work. For instance, if we have:
--
-- @
-- data Foo a = MkFoo Int a (Maybe a) (Either Int (Maybe a))
-- @
--
-- Then @'get_gen1_constrained_tys' a (f (g a))@ would return @[Either Int]@,
-- as a derived 'Generic1' instance would need to call 'fmap' at that type.
-- Invoking @'get_gen1_constrained_tys' a@ on any of the other fields would
-- return @[]@.
--
-- 'get_gen1_constrained_tys' is very similar in spirit to
-- 'deepSubtypesContaining' in "GHC.Tc.Deriv.Functor". Just like with
-- 'deepSubtypesContaining', it is important that the 'TyVar' argument come
-- from 'dataConUnivTyVars'. (See #22167 for what goes wrong if 'tyConTyVars'
-- is used.)
get_gen1_constrained_tys :: TyVar -> Type -> [Type]
get_gen1_constrained_tys :: TyVar -> Type -> [Type]
get_gen1_constrained_tys TyVar
argVar
  = TyVar -> ArgTyAlg [Type] -> Type -> [Type]
forall a. TyVar -> ArgTyAlg a -> Type -> a
argTyFold TyVar
argVar (ArgTyAlg [Type] -> Type -> [Type])
-> ArgTyAlg [Type] -> Type -> [Type]
forall a b. (a -> b) -> a -> b
$ ArgTyAlg { ata_rec0 :: Type -> [Type]
ata_rec0 = [Type] -> Type -> [Type]
forall a b. a -> b -> a
const []
                                , ata_par1 :: [Type]
ata_par1 = [], ata_rec1 :: Type -> [Type]
ata_rec1 = [Type] -> Type -> [Type]
forall a b. a -> b -> a
const []
                                , ata_comp :: Type -> [Type] -> [Type]
ata_comp = (:) }

{-

Note [Requirements for deriving Generic and Rep]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

In the following, T, Tfun, and Targ are "meta-variables" ranging over type
expressions.

(Generic T) and (Rep T) are derivable for some type expression T if the
following constraints are satisfied.

  (a) D is a type constructor *value*. In other words, D is either a type
      constructor or it is equivalent to the head of a data family instance (up to
      alpha-renaming).

  (b) D cannot have a "stupid context".
      See Note [The stupid context] in GHC.Core.DataCon.

  (c) The right-hand side of D cannot include existential types, universally
      quantified types, or "exotic" unlifted types. An exotic unlifted type
      is one which is not listed in the definition of allowedUnliftedTy
      (i.e., one for which we have no representation type).
      See Note [Generics and unlifted types]

  (d) T :: *.

(Generic1 T) and (Rep1 T) are derivable for some type expression T if the
following constraints are satisfied.

  (a),(b),(c) As above.

  (d) T must expect arguments, and its last parameter must have kind *.

      We use `a' to denote the parameter of D that corresponds to the last
      parameter of T.

  (e) For any type-level application (Tfun Targ) in the right-hand side of D
      where the head of Tfun is not a tuple constructor:

      (b1) `a' must not occur in Tfun.

      (b2) If `a' occurs in Targ, then Tfun :: * -> *.

-}

canDoGenerics :: DerivInstTys -> Validity' [DeriveGenericsErrReason]
-- canDoGenerics determines if Generic/Rep can be derived.
--
-- Check (a) from Note [Requirements for deriving Generic and Rep] is taken
-- care of because canDoGenerics is applied to rep tycons.
--
-- It returns IsValid if deriving is possible. It returns (NotValid reason)
-- if not.
canDoGenerics :: DerivInstTys -> Validity' [DeriveGenericsErrReason]
canDoGenerics dit :: DerivInstTys
dit@(DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tc})
  = [Validity' DeriveGenericsErrReason]
-> Validity' [DeriveGenericsErrReason]
forall a. [Validity' a] -> Validity' [a]
mergeErrors (
          -- Check (b) from Note [Requirements for deriving Generic and Rep].
              (if (Bool -> Bool
not ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TyCon -> [Type]
tyConStupidTheta TyCon
tc)))
                then (DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason
forall a. a -> Validity' a
NotValid (DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason)
-> DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason
forall a b. (a -> b) -> a -> b
$ TyCon -> DeriveGenericsErrReason
DerivErrGenericsMustNotHaveDatatypeContext TyCon
tc_name)
                else Validity' DeriveGenericsErrReason
forall a. Validity' a
IsValid)
          -- See comment below
            Validity' DeriveGenericsErrReason
-> [Validity' DeriveGenericsErrReason]
-> [Validity' DeriveGenericsErrReason]
forall a. a -> [a] -> [a]
: ((DataCon -> Validity' DeriveGenericsErrReason)
-> [DataCon] -> [Validity' DeriveGenericsErrReason]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Validity' DeriveGenericsErrReason
bad_con (TyCon -> [DataCon]
tyConDataCons TyCon
tc)))
  where
    -- The tc can be a representation tycon. When we want to display it to the
    -- user (in an error message) we should print its parent
    tc_name :: TyCon
tc_name = case TyCon -> Maybe (TyCon, [Type])
tyConFamInst_maybe TyCon
tc of
        Just (TyCon
ptc, [Type]
_) -> TyCon
ptc
        Maybe (TyCon, [Type])
_             -> TyCon
tc

        -- Check (c) from Note [Requirements for deriving Generic and Rep].
        --
        -- If any of the constructors has an exotic unlifted type as argument,
        -- then we can't build the embedding-projection pair, because
        -- it relies on instantiating *polymorphic* sum and product types
        -- at the argument types of the constructors
    bad_con :: DataCon -> Validity' DeriveGenericsErrReason
    bad_con :: DataCon -> Validity' DeriveGenericsErrReason
bad_con DataCon
dc = if (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Type -> Bool
bad_arg_type (DataCon -> DerivInstTys -> [Type]
derivDataConInstArgTys DataCon
dc DerivInstTys
dit)
                  then DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason
forall a. a -> Validity' a
NotValid (DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason)
-> DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason
forall a b. (a -> b) -> a -> b
$ DataCon -> DeriveGenericsErrReason
DerivErrGenericsMustNotHaveExoticArgs DataCon
dc
                  else if Bool -> Bool
not (DataCon -> Bool
isVanillaDataCon DataCon
dc)
                          then DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason
forall a. a -> Validity' a
NotValid (DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason)
-> DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason
forall a b. (a -> b) -> a -> b
$ DataCon -> DeriveGenericsErrReason
DerivErrGenericsMustBeVanillaDataCon DataCon
dc
                          else Validity' DeriveGenericsErrReason
forall a. Validity' a
IsValid

        -- Nor can we do the job if it's an existential data constructor,
        -- Nor if the args are polymorphic types (I don't think)
    bad_arg_type :: Type -> Bool
bad_arg_type Type
ty = (Type -> Bool
mightBeUnliftedType Type
ty Bool -> Bool -> Bool
&& Bool -> Bool
not (Type -> Bool
allowedUnliftedTy Type
ty))
                      Bool -> Bool -> Bool
|| Bool -> Bool
not (Type -> Bool
isTauTy Type
ty)

-- Returns True the Type argument is an unlifted type which has a
-- corresponding generic representation type. For example,
-- (allowedUnliftedTy Int#) would return True since there is the UInt
-- representation type.
allowedUnliftedTy :: Type -> Bool
allowedUnliftedTy :: Type -> Bool
allowedUnliftedTy = Maybe (RdrName, RdrName) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (RdrName, RdrName) -> Bool)
-> (Type -> Maybe (RdrName, RdrName)) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe (RdrName, RdrName)
unboxedRepRDRs

mergeErrors :: [Validity' a] -> Validity' [a]
mergeErrors :: forall a. [Validity' a] -> Validity' [a]
mergeErrors []             = Validity' [a]
forall a. Validity' a
IsValid
mergeErrors (NotValid a
s:[Validity' a]
t) = case [Validity' a] -> Validity' [a]
forall a. [Validity' a] -> Validity' [a]
mergeErrors [Validity' a]
t of
  Validity' [a]
IsValid     -> [a] -> Validity' [a]
forall a. a -> Validity' a
NotValid [a
s]
  NotValid [a]
s' -> [a] -> Validity' [a]
forall a. a -> Validity' a
NotValid (a
s a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
s')
mergeErrors (Validity' a
IsValid : [Validity' a]
t) = [Validity' a] -> Validity' [a]
forall a. [Validity' a] -> Validity' [a]
mergeErrors [Validity' a]
t
  -- NotValid s' -> NotValid (s <> text ", and" $$ s')

-- A datatype used only inside of canDoGenerics1. It's the result of analysing
-- a type term.
data Check_for_CanDoGenerics1 = CCDG1
  { Check_for_CanDoGenerics1 -> Bool
_ccdg1_hasParam :: Bool       -- does the parameter of interest occurs in
                                  -- this type?
  , Check_for_CanDoGenerics1 -> Validity' DeriveGenericsErrReason
_ccdg1_errors   :: Validity' DeriveGenericsErrReason -- errors generated by this type
  }

{-

Note [degenerate use of FFoldType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

We use foldDataConArgs here only for its ability to treat tuples
specially. foldDataConArgs also tracks covariance (though it assumes all
higher-order type parameters are covariant) and has hooks for special handling
of functions and polytypes, but we do *not* use those.

The key issue is that Generic1 deriving currently offers no sophisticated
support for functions. For example, we cannot handle

  data F a = F ((a -> Int) -> Int)

even though a is occurring covariantly.

In fact, our rule is harsh: a is simply not allowed to occur within the first
argument of (->). We treat (->) the same as any other non-tuple tycon.

Unfortunately, this means we have to track "the parameter occurs in this type"
explicitly, even though foldDataConArgs is also doing this internally.

-}

-- canDoGenerics1 determines if a Generic1/Rep1 can be derived.
--
-- Checks (a) through (c) from Note [Requirements for deriving Generic and Rep]
-- are taken care of by the call to canDoGenerics.
--
-- It returns IsValid if deriving is possible. It returns (NotValid reason)
-- if not.
canDoGenerics1 :: DerivInstTys -> Validity' [DeriveGenericsErrReason]
canDoGenerics1 :: DerivInstTys -> Validity' [DeriveGenericsErrReason]
canDoGenerics1 dit :: DerivInstTys
dit@(DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc}) =
  DerivInstTys -> Validity' [DeriveGenericsErrReason]
canDoGenerics DerivInstTys
dit Validity' [DeriveGenericsErrReason]
-> Validity' [DeriveGenericsErrReason]
-> Validity' [DeriveGenericsErrReason]
forall a. Validity' a -> Validity' a -> Validity' a
`andValid` Validity' [DeriveGenericsErrReason]
additionalChecks
  where
    additionalChecks :: Validity' [DeriveGenericsErrReason]
additionalChecks
        -- check (d) from Note [Requirements for deriving Generic and Rep]
      | [TyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TyCon -> [TyVar]
tyConTyVars TyCon
rep_tc) = [DeriveGenericsErrReason] -> Validity' [DeriveGenericsErrReason]
forall a. a -> Validity' a
NotValid [
          TyCon -> DeriveGenericsErrReason
DerivErrGenericsMustHaveSomeTypeParams TyCon
rep_tc]

      | Bool
otherwise = [Validity' DeriveGenericsErrReason]
-> Validity' [DeriveGenericsErrReason]
forall a. [Validity' a] -> Validity' [a]
mergeErrors ([Validity' DeriveGenericsErrReason]
 -> Validity' [DeriveGenericsErrReason])
-> [Validity' DeriveGenericsErrReason]
-> Validity' [DeriveGenericsErrReason]
forall a b. (a -> b) -> a -> b
$ (DataCon -> [Validity' DeriveGenericsErrReason])
-> [DataCon] -> [Validity' DeriveGenericsErrReason]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DataCon -> [Validity' DeriveGenericsErrReason]
check_con [DataCon]
data_cons

    data_cons :: [DataCon]
data_cons = TyCon -> [DataCon]
tyConDataCons TyCon
rep_tc
    check_con :: DataCon -> [Validity' DeriveGenericsErrReason]
check_con DataCon
con = case DataCon -> Validity' DeriveGenericsErrReason
check_vanilla DataCon
con of
      j :: Validity' DeriveGenericsErrReason
j@(NotValid {}) -> [Validity' DeriveGenericsErrReason
j]
      Validity' DeriveGenericsErrReason
IsValid -> Check_for_CanDoGenerics1 -> Validity' DeriveGenericsErrReason
_ccdg1_errors (Check_for_CanDoGenerics1 -> Validity' DeriveGenericsErrReason)
-> [Check_for_CanDoGenerics1]
-> [Validity' DeriveGenericsErrReason]
forall a b. (a -> b) -> [a] -> [b]
`map` FFoldType Check_for_CanDoGenerics1
-> DataCon -> DerivInstTys -> [Check_for_CanDoGenerics1]
forall a. FFoldType a -> DataCon -> DerivInstTys -> [a]
foldDataConArgs (DataCon -> FFoldType Check_for_CanDoGenerics1
ft_check DataCon
con) DataCon
con DerivInstTys
dit

    check_vanilla :: DataCon -> Validity' DeriveGenericsErrReason
    check_vanilla :: DataCon -> Validity' DeriveGenericsErrReason
check_vanilla DataCon
con | DataCon -> Bool
isVanillaDataCon DataCon
con = Validity' DeriveGenericsErrReason
forall a. Validity' a
IsValid
                      | Bool
otherwise            = DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason
forall a. a -> Validity' a
NotValid (DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason)
-> DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason
forall a b. (a -> b) -> a -> b
$ DataCon -> DeriveGenericsErrReason
DerivErrGenericsMustNotHaveExistentials DataCon
con

    bmzero :: Check_for_CanDoGenerics1
bmzero    = Bool
-> Validity' DeriveGenericsErrReason -> Check_for_CanDoGenerics1
CCDG1 Bool
False Validity' DeriveGenericsErrReason
forall a. Validity' a
IsValid
    bmbad :: DataCon -> Check_for_CanDoGenerics1
bmbad DataCon
con = Bool
-> Validity' DeriveGenericsErrReason -> Check_for_CanDoGenerics1
CCDG1 Bool
True (Validity' DeriveGenericsErrReason -> Check_for_CanDoGenerics1)
-> Validity' DeriveGenericsErrReason -> Check_for_CanDoGenerics1
forall a b. (a -> b) -> a -> b
$ DeriveGenericsErrReason -> Validity' DeriveGenericsErrReason
forall a. a -> Validity' a
NotValid (DataCon -> DeriveGenericsErrReason
DerivErrGenericsWrongArgKind DataCon
con)
    bmplus :: Check_for_CanDoGenerics1
-> Check_for_CanDoGenerics1 -> Check_for_CanDoGenerics1
bmplus (CCDG1 Bool
b1 Validity' DeriveGenericsErrReason
m1) (CCDG1 Bool
b2 Validity' DeriveGenericsErrReason
m2) = Bool
-> Validity' DeriveGenericsErrReason -> Check_for_CanDoGenerics1
CCDG1 (Bool
b1 Bool -> Bool -> Bool
|| Bool
b2) (Validity' DeriveGenericsErrReason
m1 Validity' DeriveGenericsErrReason
-> Validity' DeriveGenericsErrReason
-> Validity' DeriveGenericsErrReason
forall a. Validity' a -> Validity' a -> Validity' a
`andValid` Validity' DeriveGenericsErrReason
m2)

    -- check (e) from Note [Requirements for deriving Generic and Rep]
    -- See also Note [degenerate use of FFoldType]
    ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1
    ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1
ft_check DataCon
con = FT
      { ft_triv :: Check_for_CanDoGenerics1
ft_triv = Check_for_CanDoGenerics1
bmzero

      , ft_var :: Check_for_CanDoGenerics1
ft_var = Check_for_CanDoGenerics1
caseVar, ft_co_var :: Check_for_CanDoGenerics1
ft_co_var = Check_for_CanDoGenerics1
caseVar

      -- (component_0,component_1,...,component_n)
      , ft_tup :: TyCon -> [Check_for_CanDoGenerics1] -> Check_for_CanDoGenerics1
ft_tup = \TyCon
_ [Check_for_CanDoGenerics1]
components -> case [Check_for_CanDoGenerics1]
-> Maybe (NonEmpty Check_for_CanDoGenerics1)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Check_for_CanDoGenerics1]
components of
            Just NonEmpty Check_for_CanDoGenerics1
components' | (Check_for_CanDoGenerics1 -> Bool)
-> [Check_for_CanDoGenerics1] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Check_for_CanDoGenerics1 -> Bool
_ccdg1_hasParam (NonEmpty Check_for_CanDoGenerics1 -> [Check_for_CanDoGenerics1]
forall a. NonEmpty a -> [a]
NE.init NonEmpty Check_for_CanDoGenerics1
components') -> DataCon -> Check_for_CanDoGenerics1
bmbad DataCon
con
            Maybe (NonEmpty Check_for_CanDoGenerics1)
_ -> (Check_for_CanDoGenerics1
 -> Check_for_CanDoGenerics1 -> Check_for_CanDoGenerics1)
-> Check_for_CanDoGenerics1
-> [Check_for_CanDoGenerics1]
-> Check_for_CanDoGenerics1
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Check_for_CanDoGenerics1
-> Check_for_CanDoGenerics1 -> Check_for_CanDoGenerics1
bmplus Check_for_CanDoGenerics1
bmzero [Check_for_CanDoGenerics1]
components

      -- (dom -> rng), where the head of ty is not a tuple tycon
      , ft_fun :: Check_for_CanDoGenerics1
-> Check_for_CanDoGenerics1 -> Check_for_CanDoGenerics1
ft_fun = \Check_for_CanDoGenerics1
dom Check_for_CanDoGenerics1
rng -> -- cf #8516
          if Check_for_CanDoGenerics1 -> Bool
_ccdg1_hasParam Check_for_CanDoGenerics1
dom
          then DataCon -> Check_for_CanDoGenerics1
bmbad DataCon
con
          else Check_for_CanDoGenerics1
-> Check_for_CanDoGenerics1 -> Check_for_CanDoGenerics1
bmplus Check_for_CanDoGenerics1
dom Check_for_CanDoGenerics1
rng

      -- (ty arg), where head of ty is neither (->) nor a tuple constructor and
      -- the parameter of interest does not occur in ty
      , ft_ty_app :: Type
-> Type -> Check_for_CanDoGenerics1 -> Check_for_CanDoGenerics1
ft_ty_app = \Type
_ Type
_ Check_for_CanDoGenerics1
arg -> Check_for_CanDoGenerics1
arg

      , ft_bad_app :: Check_for_CanDoGenerics1
ft_bad_app = DataCon -> Check_for_CanDoGenerics1
bmbad DataCon
con
      , ft_forall :: TyVar -> Check_for_CanDoGenerics1 -> Check_for_CanDoGenerics1
ft_forall  = \TyVar
_ Check_for_CanDoGenerics1
body -> Check_for_CanDoGenerics1
body -- polytypes are handled elsewhere
      }
      where
        caseVar :: Check_for_CanDoGenerics1
caseVar = Bool
-> Validity' DeriveGenericsErrReason -> Check_for_CanDoGenerics1
CCDG1 Bool
True Validity' DeriveGenericsErrReason
forall a. Validity' a
IsValid

{-
************************************************************************
*                                                                      *
\subsection{Generating the RHS of a generic default method}
*                                                                      *
************************************************************************
-}

type US = Int   -- Local unique supply, just a plain Int
type Alt = (LPat GhcPs, LHsExpr GhcPs)

-- GenericKind serves to mark if a datatype derives Generic (Gen0) or
-- Generic1 (Gen1).
data GenericKind = Gen0 | Gen1

-- Like 'GenericKind', but with a payload of a datacon's last universally
-- quantified 'TyVar' in the 'Generic1' case.
--
-- Note that for GADTs, the last TyVar's Name will be different in each data
-- constructor, so it is not correct to simply use the last TyVar in
-- 'tyConTyVars' in 'Gen1_DC'. (See #21185 for an example of what would happen
-- if you tried.)
data GenericKind_DC = Gen0_DC | Gen1_DC TyVar

-- Construct a 'GenericKind_DC', retrieving the last universally quantified
-- type variable of a 'DataCon' in the 'Generic1' case.
gk2gkDC :: GenericKind -> DataCon -> [Type] -> GenericKind_DC
gk2gkDC :: GenericKind -> DataCon -> [Type] -> GenericKind_DC
gk2gkDC GenericKind
Gen0 DataCon
_  [Type]
_       = GenericKind_DC
Gen0_DC
gk2gkDC GenericKind
Gen1 DataCon
dc [Type]
tc_args = TyVar -> GenericKind_DC
Gen1_DC (TyVar -> GenericKind_DC) -> TyVar -> GenericKind_DC
forall a b. (a -> b) -> a -> b
$ Bool -> TyVar -> TyVar
forall a. HasCallStack => Bool -> a -> a
assert (Type -> Bool
isTyVarTy Type
last_dc_inst_univ)
                                  (TyVar -> TyVar) -> TyVar -> TyVar
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Type -> TyVar
Type -> TyVar
getTyVar Type
last_dc_inst_univ
  where
    dc_inst_univs :: [Type]
dc_inst_univs = DataCon -> [Type] -> [Type]
dataConInstUnivs DataCon
dc [Type]
tc_args
    last_dc_inst_univ :: Type
last_dc_inst_univ = Bool -> Type -> Type
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
dc_inst_univs)) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                        [Type] -> Type
forall a. HasCallStack => [a] -> a
Partial.last [Type]
dc_inst_univs


-- Bindings for the Generic instance
mkBindsRep :: DynFlags -> GenericKind -> SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, [LSig GhcPs])
mkBindsRep :: DynFlags
-> GenericKind
-> SrcSpan
-> DerivInstTys
-> (LHsBinds GhcPs, [LSig GhcPs])
mkBindsRep DynFlags
dflags GenericKind
gk SrcSpan
loc dit :: DerivInstTys
dit@(DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tycon}) = (LHsBinds GhcPs
[GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
binds, [LSig GhcPs]
[GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs)
      where
        binds :: [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
binds = [LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBind (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc' RdrName
from01_RDR) [LMatch GhcPs (LHsExpr GhcPs)
GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))
from_eqn]]
              [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
-> [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
-> [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
forall a. [a] -> [a] -> [a]
++
                [LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBind (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc' RdrName
to01_RDR) [LMatch GhcPs (LHsExpr GhcPs)
GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))
to_eqn]]

        -- See Note [Generics performance tricks]
        sigs :: [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs = if     GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_InlineGenericsAggressively DynFlags
dflags
                  Bool -> Bool -> Bool
|| (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_InlineGenerics DynFlags
dflags Bool -> Bool -> Bool
&& Bool
inlining_useful)
               then [RdrName -> GenLocated SrcSpanAnnA (Sig GhcPs)
inline1 RdrName
from01_RDR, RdrName -> GenLocated SrcSpanAnnA (Sig GhcPs)
inline1 RdrName
to01_RDR]
               else []
         where
           inlining_useful :: Bool
inlining_useful
             | US
cons US -> US -> Bool
forall a. Ord a => a -> a -> Bool
<= US
1  = Bool
True
             | US
cons US -> US -> Bool
forall a. Ord a => a -> a -> Bool
<= US
4  = US
max_fields US -> US -> Bool
forall a. Ord a => a -> a -> Bool
<= US
5
             | US
cons US -> US -> Bool
forall a. Ord a => a -> a -> Bool
<= US
8  = US
max_fields US -> US -> Bool
forall a. Ord a => a -> a -> Bool
<= US
2
             | US
cons US -> US -> Bool
forall a. Ord a => a -> a -> Bool
<= US
16 = US
max_fields US -> US -> Bool
forall a. Ord a => a -> a -> Bool
<= US
1
             | US
cons US -> US -> Bool
forall a. Ord a => a -> a -> Bool
<= US
24 = US
max_fields US -> US -> Bool
forall a. Eq a => a -> a -> Bool
== US
0
             | Bool
otherwise  = Bool
False
             where
               cons :: US
cons       = [DataCon] -> US
forall a. [a] -> US
forall (t :: * -> *) a. Foldable t => t a -> US
length [DataCon]
datacons
               max_fields :: US
max_fields = [US] -> US
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([US] -> US) -> [US] -> US
forall a b. (a -> b) -> a -> b
$ (DataCon -> US) -> [DataCon] -> [US]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> US
dataConSourceArity [DataCon]
datacons

           inline1 :: RdrName -> GenLocated SrcSpanAnnA (Sig GhcPs)
inline1 RdrName
f = SrcSpanAnnA -> Sig GhcPs -> GenLocated SrcSpanAnnA (Sig GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc'' (Sig GhcPs -> GenLocated SrcSpanAnnA (Sig GhcPs))
-> (InlinePragma -> Sig GhcPs)
-> InlinePragma
-> GenLocated SrcSpanAnnA (Sig GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XInlineSig GhcPs -> LIdP GhcPs -> InlinePragma -> Sig GhcPs
forall pass.
XInlineSig pass -> LIdP pass -> InlinePragma -> Sig pass
InlineSig XInlineSig GhcPs
forall a. NoAnn a => a
noAnn (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc' RdrName
f)
                     (InlinePragma -> GenLocated SrcSpanAnnA (Sig GhcPs))
-> InlinePragma -> GenLocated SrcSpanAnnA (Sig GhcPs)
forall a b. (a -> b) -> a -> b
$ InlinePragma
alwaysInlinePragma { inl_act = ActiveAfter NoSourceText 1 }

        -- The topmost M1 (the datatype metadata) has the exact same type
        -- across all cases of a from/to definition, and can be factored out
        -- to save some allocations during typechecking.
        -- See Note [Generics compilation speed tricks]
        from_eqn :: LMatch GhcPs (LocatedA (HsExpr GhcPs))
from_eqn = LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
x_Pat (LocatedA (HsExpr GhcPs) -> LMatch GhcPs (LocatedA (HsExpr GhcPs)))
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
mkM1_E
                                       (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
IsPass p =>
LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
nlHsPar (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase LHsExpr GhcPs
x_Expr [LMatch GhcPs (LHsExpr GhcPs)]
[GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
from_matches
        to_eqn :: LMatch GhcPs (LocatedA (HsExpr GhcPs))
to_eqn   = LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (LPat GhcPs -> LPat GhcPs
mkM1_P LPat GhcPs
x_Pat) (LocatedA (HsExpr GhcPs) -> LMatch GhcPs (LocatedA (HsExpr GhcPs)))
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase LHsExpr GhcPs
x_Expr [LMatch GhcPs (LHsExpr GhcPs)]
[GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
to_matches

        from_matches :: [GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
from_matches  = [LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
pat LocatedA (HsExpr GhcPs)
rhs | (GenLocated SrcSpanAnnA (Pat GhcPs)
pat,LocatedA (HsExpr GhcPs)
rhs) <- [Alt]
[(GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))]
from_alts]
        to_matches :: [GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
to_matches    = [LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
pat LocatedA (HsExpr GhcPs)
rhs | (GenLocated SrcSpanAnnA (Pat GhcPs)
pat,LocatedA (HsExpr GhcPs)
rhs) <- [Alt]
[(GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))]
to_alts  ]
        loc' :: SrcSpanAnnN
loc'          = SrcSpan -> SrcSpanAnnN
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc
        loc'' :: SrcSpanAnnA
loc''         = SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc
        datacons :: [DataCon]
datacons      = TyCon -> [DataCon]
tyConDataCons TyCon
tycon

        (RdrName
from01_RDR, RdrName
to01_RDR) = case GenericKind
gk of
                                   GenericKind
Gen0 -> (RdrName
from_RDR,  RdrName
to_RDR)
                                   GenericKind
Gen1 -> (RdrName
from1_RDR, RdrName
to1_RDR)

        -- Recurse over the sum first
        from_alts, to_alts :: [Alt]
        ([Alt]
[(GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))]
from_alts, [Alt]
[(GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))]
to_alts) = GenericKind -> US -> DerivInstTys -> [DataCon] -> ([Alt], [Alt])
mkSum GenericKind
gk (US
1 :: US) DerivInstTys
dit [DataCon]
datacons

--------------------------------------------------------------------------------
-- The type synonym instance and synonym
--       type instance Rep (D a b) = Rep_D a b
--       type Rep_D a b = ...representation type for D ...
--------------------------------------------------------------------------------

gen_Generic_fam_inst :: GenericKind      -- Gen0 or Gen1
                     -> (Name -> Fixity) -- Get the Fixity for a data constructor Name
                     -> SrcSpan          -- The current source location
                     -> DerivInstTys     -- Information about the type(s) to which
                                         -- Generic(1) is applied in the generated
                                         -- instance, including the data type's TyCon
                     -> TcM FamInst      -- Generated representation0 coercion
gen_Generic_fam_inst :: GenericKind
-> (Name -> Fixity) -> SrcSpan -> DerivInstTys -> TcM FamInst
gen_Generic_fam_inst GenericKind
gk Name -> Fixity
get_fixity SrcSpan
loc
       dit :: DerivInstTys
dit@(DerivInstTys{ dit_cls_tys :: DerivInstTys -> [Type]
dit_cls_tys = [Type]
cls_tys
                        , dit_tc :: DerivInstTys -> TyCon
dit_tc = TyCon
tc, dit_tc_args :: DerivInstTys -> [Type]
dit_tc_args = [Type]
tc_args
                        , dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tycon }) =
       -- Consider the example input tycon `D`, where data D a b = D_ a
       -- Also consider `R:DInt`, where { data family D x y :: * -> *
       --                               ; data instance D Int a b = D_ a }
  do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family)
       fam_tc <- case GenericKind
gk of
         GenericKind
Gen0 -> Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
repTyConName
         GenericKind
Gen1 -> Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
rep1TyConName

     ; let -- If the derived instance is
           --   instance Generic (Foo x)
           -- then:
           --   `arg_ki` = *, `inst_ty` = Foo x :: *
           --
           -- If the derived instance is
           --   instance Generic1 (Bar x :: k -> *)
           -- then:
           --   `arg_k` = k, `inst_ty` = Bar x :: k -> *
           arg_ki = case (GenericKind
gk, [Type]
cls_tys) of
             (GenericKind
Gen0, [])      -> Type
liftedTypeKind
             (GenericKind
Gen1, [Type
arg_k]) -> Type
arg_k
             (GenericKind, [Type])
_ -> String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"gen_Generic_fam_insts" ([Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
cls_tys)
           inst_ty = TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
tc_args
           inst_tys = [Type]
cls_tys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
inst_ty]

       -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
     ; repTy <- tc_mkRepTy gk get_fixity dit arg_ki

       -- `rep_name` is a name we generate for the synonym
     ; mod <- getModule
     ; let tc_occ  = Name -> OccName
nameOccName (TyCon -> Name
tyConName TyCon
tycon)
           rep_occ = case GenericKind
gk of GenericKind
Gen0 -> OccName -> OccName
mkGenR OccName
tc_occ; GenericKind
Gen1 -> OccName -> OccName
mkGen1R OccName
tc_occ
     ; rep_name <- newGlobalBinder mod rep_occ loc

     ; let tcv      = Type -> [TyVar]
tyCoVarsOfTypeList Type
inst_ty
           (tv, cv) = partition isTyVar tcv
           tvs      = [TyVar] -> [TyVar]
scopedSort [TyVar]
tv
           cvs      = [TyVar] -> [TyVar]
scopedSort [TyVar]
cv
           axiom    = Role
-> Name
-> [TyVar]
-> [TyVar]
-> [TyVar]
-> TyCon
-> [Type]
-> Type
-> CoAxiom Unbranched
mkSingleCoAxiom Role
Nominal Name
rep_name [TyVar]
tvs [] [TyVar]
cvs
                                      TyCon
fam_tc [Type]
inst_tys Type
repTy

     ; newFamInst SynFamilyInst axiom  }

--------------------------------------------------------------------------------
-- Type representation
--------------------------------------------------------------------------------

-- | See documentation of 'argTyFold'; that function uses the fields of this
-- type to interpret the structure of a type when that type is considered as an
-- argument to a constructor that is being represented with 'Rep1'.
data ArgTyAlg a = ArgTyAlg
  { forall a. ArgTyAlg a -> Type -> a
ata_rec0 :: (Type -> a)
  , forall a. ArgTyAlg a -> a
ata_par1 :: a, forall a. ArgTyAlg a -> Type -> a
ata_rec1 :: (Type -> a)
  , forall a. ArgTyAlg a -> Type -> a -> a
ata_comp :: (Type -> a -> a)
  }

-- | @argTyFold@ implements a generalised and safer variant of the @arg@
-- function from Figure 3 in <http://dreixel.net/research/pdf/gdmh.pdf>. @arg@
-- is conceptually equivalent to:
--
-- > arg t = case t of
-- >   _ | isTyVar t         -> if (t == argVar) then Par1 else Par0 t
-- >   App f [t'] |
-- >     representable1 f &&
-- >     t' == argVar        -> Rec1 f
-- >   App f [t'] |
-- >     representable1 f &&
-- >     t' has tyvars       -> f :.: (arg t')
-- >   _                     -> Rec0 t
--
-- where @argVar@ is the last type variable in the data type declaration we are
-- finding the representation for.
--
-- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to
-- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and
-- @:.:@.
--
-- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for
-- some data types. The problematic case is when @t@ is an application of a
-- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the
-- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in
-- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some
-- representable1 checks have been relaxed, and others were moved to
-- @canDoGenerics1@.
argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a
argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a
argTyFold TyVar
argVar (ArgTyAlg {ata_rec0 :: forall a. ArgTyAlg a -> Type -> a
ata_rec0 = Type -> a
mkRec0,
                            ata_par1 :: forall a. ArgTyAlg a -> a
ata_par1 = a
mkPar1, ata_rec1 :: forall a. ArgTyAlg a -> Type -> a
ata_rec1 = Type -> a
mkRec1,
                            ata_comp :: forall a. ArgTyAlg a -> Type -> a -> a
ata_comp = Type -> a -> a
mkComp}) =
  -- mkRec0 is the default; use it if there is no interesting structure
  -- (e.g. occurrences of parameters or recursive occurrences)
  \Type
t -> a -> (a -> a) -> Maybe a -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Type -> a
mkRec0 Type
t) a -> a
forall a. a -> a
id (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ Type -> Maybe a
go Type
t where
  go :: Type -> -- type to fold through
        Maybe a -- the result (e.g. representation type), unless it's trivial
  go :: Type -> Maybe a
go Type
t = Maybe a
isParam Maybe a -> Maybe a -> Maybe a
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe a
isApp where

    isParam :: Maybe a
isParam = do -- handles parameters
      t' <- Type -> Maybe TyVar
getTyVar_maybe Type
t
      Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter
             else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0

    isApp :: Maybe a
isApp = do -- handles applications
      (phi, beta) <- Type -> Maybe (Type, Type)
tcSplitAppTy_maybe Type
t

      let interesting = TyVar
argVar TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
exactTyCoVarsOfType Type
beta

      -- Does it have no interesting structure to represent?
      if not interesting then Nothing
        else -- Is the argument the parameter? Special case for mkRec1.
          if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi
            else mkComp phi `fmap` go beta -- It must be a composition.


tc_mkRepTy ::  -- Gen0 or Gen1, for Rep or Rep1
               GenericKind
               -- Get the Fixity for a data constructor Name
            -> (Name -> Fixity)
               -- Information about the last type argument to Generic(1)
            -> DerivInstTys
               -- The kind of the representation type's argument
               -- See Note [Handling kinds in a Rep instance]
            -> Kind
               -- Generated representation0 type
            -> TcM Type
tc_mkRepTy :: GenericKind -> (Name -> Fixity) -> DerivInstTys -> Type -> TcM Type
tc_mkRepTy GenericKind
gk Name -> Fixity
get_fixity dit :: DerivInstTys
dit@(DerivInstTys{ dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tycon
                                          , dit_rep_tc_args :: DerivInstTys -> [Type]
dit_rep_tc_args = [Type]
tycon_args }) Type
k =
  do
    d1      <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
d1TyConName
    c1      <- tcLookupTyCon c1TyConName
    s1      <- tcLookupTyCon s1TyConName
    rec0    <- tcLookupTyCon rec0TyConName
    rec1    <- tcLookupTyCon rec1TyConName
    par1    <- tcLookupTyCon par1TyConName
    u1      <- tcLookupTyCon u1TyConName
    v1      <- tcLookupTyCon v1TyConName
    plus    <- tcLookupTyCon sumTyConName
    times   <- tcLookupTyCon prodTyConName
    comp    <- tcLookupTyCon compTyConName
    uAddr   <- tcLookupTyCon uAddrTyConName
    uChar   <- tcLookupTyCon uCharTyConName
    uDouble <- tcLookupTyCon uDoubleTyConName
    uFloat  <- tcLookupTyCon uFloatTyConName
    uInt    <- tcLookupTyCon uIntTyConName
    uWord   <- tcLookupTyCon uWordTyConName

    let tcLookupPromDataCon = (DataCon -> TyCon)
-> IOEnv (Env TcGblEnv TcLclEnv) DataCon
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DataCon -> TyCon
promoteDataCon (IOEnv (Env TcGblEnv TcLclEnv) DataCon
 -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> (Name -> IOEnv (Env TcGblEnv TcLclEnv) DataCon)
-> Name
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> IOEnv (Env TcGblEnv TcLclEnv) DataCon
tcLookupDataCon

    md         <- tcLookupPromDataCon metaDataDataConName
    mc         <- tcLookupPromDataCon metaConsDataConName
    ms         <- tcLookupPromDataCon metaSelDataConName
    pPrefix    <- tcLookupPromDataCon prefixIDataConName
    pInfix     <- tcLookupPromDataCon infixIDataConName
    pLA        <- tcLookupPromDataCon leftAssociativeDataConName
    pRA        <- tcLookupPromDataCon rightAssociativeDataConName
    pNA        <- tcLookupPromDataCon notAssociativeDataConName
    pSUpk      <- tcLookupPromDataCon sourceUnpackDataConName
    pSNUpk     <- tcLookupPromDataCon sourceNoUnpackDataConName
    pNSUpkness <- tcLookupPromDataCon noSourceUnpackednessDataConName
    pSLzy      <- tcLookupPromDataCon sourceLazyDataConName
    pSStr      <- tcLookupPromDataCon sourceStrictDataConName
    pNSStrness <- tcLookupPromDataCon noSourceStrictnessDataConName
    pDLzy      <- tcLookupPromDataCon decidedLazyDataConName
    pDStr      <- tcLookupPromDataCon decidedStrictDataConName
    pDUpk      <- tcLookupPromDataCon decidedUnpackDataConName

    let mkSum' Type
a Type
b = TyCon -> [Type] -> Type
mkTyConApp TyCon
plus  [Type
k,Type
a,Type
b]
        mkProd Type
a Type
b = TyCon -> [Type] -> Type
mkTyConApp TyCon
times [Type
k,Type
a,Type
b]
        mkRec0 Type
a   = TyCon
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> Type
-> Type
-> Type
mkBoxTy TyCon
uAddr TyCon
uChar TyCon
uDouble TyCon
uFloat TyCon
uInt TyCon
uWord TyCon
rec0 Type
k Type
a
        mkRec1 Type
a   = TyCon -> [Type] -> Type
mkTyConApp TyCon
rec1  [Type
k,Type
a]
        mkPar1     = TyCon -> Type
mkTyConTy  TyCon
par1
        mkD    TyCon
a   = TyCon -> [Type] -> Type
mkTyConApp TyCon
d1 [ Type
k, Type
metaDataTy, [DataCon] -> Type
sumP (TyCon -> [DataCon]
tyConDataCons TyCon
a) ]
        mkC      DataCon
a = TyCon -> [Type] -> Type
mkTyConApp TyCon
c1 [ Type
k
                                   , DataCon -> Type
metaConsTy DataCon
a
                                   , GenericKind_DC
-> [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type
prod (GenericKind -> DataCon -> [Type] -> GenericKind_DC
gk2gkDC GenericKind
gk DataCon
a [Type]
tycon_args)
                                          (DataCon -> DerivInstTys -> [Type]
derivDataConInstArgTys DataCon
a DerivInstTys
dit)
                                          (DataCon -> [HsSrcBang]
dataConSrcBangs    DataCon
a)
                                          (DataCon -> [HsImplBang]
dataConImplBangs   DataCon
a)
                                          (DataCon -> [FieldLabel]
dataConFieldLabels DataCon
a)]
        mkS Maybe FieldLabel
mlbl SrcUnpackedness
su SrcStrictness
ss HsImplBang
ib Type
a = TyCon -> [Type] -> Type
mkTyConApp TyCon
s1 [Type
k, Maybe FieldLabel
-> SrcUnpackedness -> SrcStrictness -> HsImplBang -> Type
metaSelTy Maybe FieldLabel
mlbl SrcUnpackedness
su SrcStrictness
ss HsImplBang
ib, Type
a]

        -- Sums and products are done in the same way for both Rep and Rep1
        sumP [DataCon]
l = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal Type -> Type -> Type
mkSum' (TyCon -> [Type] -> Type
mkTyConApp TyCon
v1 [Type
k]) ([Type] -> Type) -> ([DataCon] -> [Type]) -> [DataCon] -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DataCon -> Type) -> [DataCon] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Type
mkC ([DataCon] -> Type) -> [DataCon] -> Type
forall a b. (a -> b) -> a -> b
$ [DataCon]
l
        -- The Bool is True if this constructor has labelled fields
        prod :: GenericKind_DC -> [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type
        prod GenericKind_DC
gk_ [Type]
l [HsSrcBang]
sb [HsImplBang]
ib [FieldLabel]
fl = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal Type -> Type -> Type
mkProd (TyCon -> [Type] -> Type
mkTyConApp TyCon
u1 [Type
k])
                                  [ Bool -> Type -> Type
forall a. HasCallStack => Bool -> a -> a
assert ([FieldLabel] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLabel]
fl Bool -> Bool -> Bool
|| [FieldLabel] -> US -> Bool
forall a. [a] -> US -> Bool
lengthExceeds [FieldLabel]
fl US
j) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                                    GenericKind_DC
-> Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type
arg GenericKind_DC
gk_ Type
t HsSrcBang
sb' HsImplBang
ib' (if [FieldLabel] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLabel]
fl
                                                       then Maybe FieldLabel
forall a. Maybe a
Nothing
                                                       else FieldLabel -> Maybe FieldLabel
forall a. a -> Maybe a
Just ([FieldLabel]
fl [FieldLabel] -> US -> FieldLabel
forall a. HasCallStack => [a] -> US -> a
!! US
j))
                                  | (Type
t,HsSrcBang
sb',HsImplBang
ib',US
j) <- [Type]
-> [HsSrcBang]
-> [HsImplBang]
-> [US]
-> [(Type, HsSrcBang, HsImplBang, US)]
forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
zip4 [Type]
l [HsSrcBang]
sb [HsImplBang]
ib [US
0..] ]

        arg :: GenericKind_DC -> Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type
        arg GenericKind_DC
gk_ Type
t (HsSrcBang SourceText
_ (HsBang SrcUnpackedness
su SrcStrictness
ss)) HsImplBang
ib Maybe FieldLabel
fl = Maybe FieldLabel
-> SrcUnpackedness -> SrcStrictness -> HsImplBang -> Type -> Type
mkS Maybe FieldLabel
fl SrcUnpackedness
su SrcStrictness
ss HsImplBang
ib (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ case GenericKind_DC
gk_ of
            -- Here we previously used Par0 if t was a type variable, but we
            -- realized that we can't always guarantee that we are wrapping-up
            -- all type variables in Par0. So we decided to stop using Par0
            -- altogether, and use Rec0 all the time.
                      GenericKind_DC
Gen0_DC        -> Type -> Type
mkRec0 Type
t
                      Gen1_DC TyVar
argVar -> TyVar -> Type -> Type
argPar TyVar
argVar Type
t
          where
            -- Builds argument representation for Rep1 (more complicated due to
            -- the presence of composition).
            argPar :: TyVar -> Type -> Type
argPar TyVar
argVar =
              let -- If deriving Generic1, make sure to substitute the last
                  -- type variable with Any in the generated Rep1 instance.
                  -- This avoids issues like what is documented in the
                  -- "wrinkle" section of
                  -- Note [Generating a correctly typed Rep instance].
                  env :: TvSubstEnv
env      = [TyVar] -> [Type] -> TvSubstEnv
HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv
zipTyEnv [TyVar
argVar] [Type -> Type
anyTypeOfKind (TyVar -> Type
tyVarKind TyVar
argVar)]
                  in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet ([Type] -> VarSet
tyCoVarsOfTypes [Type]
tycon_args)
                  subst :: Subst
subst    = InScopeSet -> TvSubstEnv -> Subst
mkTvSubst InScopeSet
in_scope TvSubstEnv
env in

              HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst (Type -> Type) -> (Type -> Type) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> ArgTyAlg Type -> Type -> Type
forall a. TyVar -> ArgTyAlg a -> Type -> a
argTyFold TyVar
argVar (ArgTyAlg
              {ata_rec0 :: Type -> Type
ata_rec0 = Type -> Type
mkRec0, ata_par1 :: Type
ata_par1 = Type
mkPar1,
               ata_rec1 :: Type -> Type
ata_rec1 = Type -> Type
mkRec1, ata_comp :: Type -> Type -> Type
ata_comp = TyCon -> Type -> Type -> Type -> Type
mkComp TyCon
comp Type
k})

        tyConName_user = case TyCon -> Maybe (TyCon, [Type])
tyConFamInst_maybe TyCon
tycon of
                           Just (TyCon
ptycon, [Type]
_) -> TyCon -> Name
tyConName TyCon
ptycon
                           Maybe (TyCon, [Type])
Nothing          -> TyCon -> Name
tyConName TyCon
tycon

        dtName  = FastString -> Type
mkStrLitTy (FastString -> Type) -> (Name -> FastString) -> Name -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> FastString
occNameFS (OccName -> FastString) -> (Name -> OccName) -> Name -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ Name
tyConName_user
        mdName  = FastString -> Type
mkStrLitTy (FastString -> Type) -> (TyCon -> FastString) -> TyCon -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> FastString
moduleNameFS (ModuleName -> FastString)
-> (TyCon -> ModuleName) -> TyCon -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName
                (Module -> ModuleName) -> (TyCon -> Module) -> TyCon -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Name -> Module
Name -> Module
nameModule (Name -> Module) -> (TyCon -> Name) -> TyCon -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> Name
tyConName (TyCon -> Type) -> TyCon -> Type
forall a b. (a -> b) -> a -> b
$ TyCon
tycon
        pkgName = FastString -> Type
mkStrLitTy (FastString -> Type) -> (TyCon -> FastString) -> TyCon -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unit -> FastString
forall u. IsUnitId u => u -> FastString
unitFS (Unit -> FastString) -> (TyCon -> Unit) -> TyCon -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit
                (Module -> Unit) -> (TyCon -> Module) -> TyCon -> Unit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Name -> Module
Name -> Module
nameModule (Name -> Module) -> (TyCon -> Name) -> TyCon -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> Name
tyConName (TyCon -> Type) -> TyCon -> Type
forall a b. (a -> b) -> a -> b
$ TyCon
tycon
        isNT    = TyCon -> Type
mkTyConTy (TyCon -> Type) -> TyCon -> Type
forall a b. (a -> b) -> a -> b
$ if TyCon -> Bool
isNewTyCon TyCon
tycon
                              then TyCon
promotedTrueDataCon
                              else TyCon
promotedFalseDataCon

        ctName = FastString -> Type
mkStrLitTy (FastString -> Type) -> (DataCon -> FastString) -> DataCon -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> FastString
occNameFS (OccName -> FastString)
-> (DataCon -> OccName) -> DataCon -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName (Name -> OccName) -> (DataCon -> Name) -> DataCon -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> Name
dataConName
        ctFix DataCon
c
            | DataCon -> Bool
dataConIsInfix DataCon
c
            = case Name -> Fixity
get_fixity (DataCon -> Name
dataConName DataCon
c) of
                   Fixity US
n FixityDirection
InfixL -> US -> TyCon -> Type
buildFix US
n TyCon
pLA
                   Fixity US
n FixityDirection
InfixR -> US -> TyCon -> Type
buildFix US
n TyCon
pRA
                   Fixity US
n FixityDirection
InfixN -> US -> TyCon -> Type
buildFix US
n TyCon
pNA
            | Bool
otherwise = TyCon -> Type
mkTyConTy TyCon
pPrefix
        buildFix US
n TyCon
assoc = TyCon -> [Type] -> Type
mkTyConApp TyCon
pInfix [ TyCon -> Type
mkTyConTy TyCon
assoc
                                             , Integer -> Type
mkNumLitTy (US -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral US
n)]

        isRec DataCon
c = TyCon -> Type
mkTyConTy (TyCon -> Type) -> TyCon -> Type
forall a b. (a -> b) -> a -> b
$ if DataCon -> [FieldLabel]
dataConFieldLabels DataCon
c [FieldLabel] -> US -> Bool
forall a. [a] -> US -> Bool
`lengthExceeds` US
0
                              then TyCon
promotedTrueDataCon
                              else TyCon
promotedFalseDataCon

        selName = FastString -> Type
mkStrLitTy (FastString -> Type)
-> (FieldLabel -> FastString) -> FieldLabel -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLabelString -> FastString
field_label (FieldLabelString -> FastString)
-> (FieldLabel -> FieldLabelString) -> FieldLabel -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLabel -> FieldLabelString
flLabel

        mbSel Maybe FieldLabel
Nothing  = TyCon -> [Type] -> Type
mkTyConApp TyCon
promotedNothingDataCon [Type
typeSymbolKind]
        mbSel (Just FieldLabel
s) = TyCon -> [Type] -> Type
mkTyConApp TyCon
promotedJustDataCon
                                    [Type
typeSymbolKind, FieldLabel -> Type
selName FieldLabel
s]

        metaDataTy   = TyCon -> [Type] -> Type
mkTyConApp TyCon
md [Type
dtName, Type
mdName, Type
pkgName, Type
isNT]
        metaConsTy DataCon
c = TyCon -> [Type] -> Type
mkTyConApp TyCon
mc [DataCon -> Type
ctName DataCon
c, DataCon -> Type
ctFix DataCon
c, DataCon -> Type
isRec DataCon
c]
        metaSelTy Maybe FieldLabel
mlbl SrcUnpackedness
su SrcStrictness
ss HsImplBang
ib =
            TyCon -> [Type] -> Type
mkTyConApp TyCon
ms [Maybe FieldLabel -> Type
mbSel Maybe FieldLabel
mlbl, Type
pSUpkness, Type
pSStrness, Type
pDStrness]
          where
            pSUpkness :: Type
pSUpkness = TyCon -> Type
mkTyConTy (TyCon -> Type) -> TyCon -> Type
forall a b. (a -> b) -> a -> b
$ case SrcUnpackedness
su of
                                         SrcUnpackedness
SrcUnpack   -> TyCon
pSUpk
                                         SrcUnpackedness
SrcNoUnpack -> TyCon
pSNUpk
                                         SrcUnpackedness
NoSrcUnpack -> TyCon
pNSUpkness

            pSStrness :: Type
pSStrness = TyCon -> Type
mkTyConTy (TyCon -> Type) -> TyCon -> Type
forall a b. (a -> b) -> a -> b
$ case SrcStrictness
ss of
                                         SrcStrictness
SrcLazy     -> TyCon
pSLzy
                                         SrcStrictness
SrcStrict   -> TyCon
pSStr
                                         SrcStrictness
NoSrcStrict -> TyCon
pNSStrness

            pDStrness :: Type
pDStrness = TyCon -> Type
mkTyConTy (TyCon -> Type) -> TyCon -> Type
forall a b. (a -> b) -> a -> b
$ case HsImplBang
ib of
                                         HsImplBang
HsLazy      -> TyCon
pDLzy
                                         HsStrict Bool
_  -> TyCon
pDStr
                                         HsUnpack{}  -> TyCon
pDUpk

    return (mkD tycon)

mkComp :: TyCon -> Kind -> Type -> Type -> Type
mkComp :: TyCon -> Type -> Type -> Type -> Type
mkComp TyCon
comp Type
k Type
f Type
g
  | Bool
k1_first  = TyCon -> [Type] -> Type
mkTyConApp TyCon
comp  [Type
k,Type
liftedTypeKind,Type
f,Type
g]
  | Bool
otherwise = TyCon -> [Type] -> Type
mkTyConApp TyCon
comp  [Type
liftedTypeKind,Type
k,Type
f,Type
g]
  where
    -- Which of these is the case?
    --     newtype (:.:) {k1} {k2} (f :: k2->*) (g :: k1->k2) (p :: k1) = ...
    -- or  newtype (:.:) {k2} {k1} (f :: k2->*) (g :: k1->k2) (p :: k1) = ...
    -- We want to instantiate with k1=k, and k2=*
    --    Reason for k2=*: see Note [Handling kinds in a Rep instance]
    -- But we need to know which way round!
    k1_first :: Bool
k1_first = TyVar
k_first TyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TyVar
p_kind_var
    [TyVar
k_first,TyVar
_,TyVar
_,TyVar
_,TyVar
p] = TyCon -> [TyVar]
tyConTyVars TyCon
comp
    Just TyVar
p_kind_var = Type -> Maybe TyVar
getTyVar_maybe (TyVar -> Type
tyVarKind TyVar
p)

-- Given the TyCons for each URec-related type synonym, check to see if the
-- given type is an unlifted type that generics understands. If so, return
-- its representation type. Otherwise, return Rec0.
-- See Note [Generics and unlifted types]
mkBoxTy :: TyCon -- UAddr
        -> TyCon -- UChar
        -> TyCon -- UDouble
        -> TyCon -- UFloat
        -> TyCon -- UInt
        -> TyCon -- UWord
        -> TyCon -- Rec0
        -> Kind  -- What to instantiate Rec0's kind variable with
        -> Type
        -> Type
mkBoxTy :: TyCon
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> Type
-> Type
-> Type
mkBoxTy TyCon
uAddr TyCon
uChar TyCon
uDouble TyCon
uFloat TyCon
uInt TyCon
uWord TyCon
rec0 Type
k Type
ty
  | Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
addrPrimTy   = TyCon -> [Type] -> Type
mkTyConApp TyCon
uAddr   [Type
k]
  | Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
charPrimTy   = TyCon -> [Type] -> Type
mkTyConApp TyCon
uChar   [Type
k]
  | Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
doublePrimTy = TyCon -> [Type] -> Type
mkTyConApp TyCon
uDouble [Type
k]
  | Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
floatPrimTy  = TyCon -> [Type] -> Type
mkTyConApp TyCon
uFloat  [Type
k]
  | Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
intPrimTy    = TyCon -> [Type] -> Type
mkTyConApp TyCon
uInt    [Type
k]
  | Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
wordPrimTy   = TyCon -> [Type] -> Type
mkTyConApp TyCon
uWord   [Type
k]
  | Bool
otherwise                = TyCon -> [Type] -> Type
mkTyConApp TyCon
rec0    [Type
k,Type
ty]

--------------------------------------------------------------------------------
-- Dealing with sums
--------------------------------------------------------------------------------

mkSum :: GenericKind  -- Generic or Generic1?
      -> US           -- Base for generating unique names
      -> DerivInstTys -- Information about the last type argument to Generic(1)
      -> [DataCon]    -- The data constructors
      -> ([Alt],      -- Alternatives for the T->Trep "from" function
          [Alt])      -- Alternatives for the Trep->T "to" function

-- Datatype without any constructors
mkSum :: GenericKind -> US -> DerivInstTys -> [DataCon] -> ([Alt], [Alt])
mkSum GenericKind
_ US
_ DerivInstTys
_ [] = ([Alt
(GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))
from_alt], [Alt
(GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))
to_alt])
  where
    from_alt :: (GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))
from_alt = (LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
x_Pat, LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase LHsExpr GhcPs
x_Expr [])
    to_alt :: (GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))
to_alt   = (LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
x_Pat, LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase LHsExpr GhcPs
x_Expr [])
               -- These M1s are meta-information for the datatype

-- Datatype with at least one constructor
mkSum GenericKind
gk US
us DerivInstTys
dit [DataCon]
datacons =
  -- switch the payload of gk_ to be datacon-centric instead of tycon-centric
 [((GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs)),
  (GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs)))]
-> ([(GenLocated SrcSpanAnnA (Pat GhcPs),
      LocatedA (HsExpr GhcPs))],
    [(GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))])
forall a b. [(a, b)] -> ([a], [b])
unzip [ GenericKind
-> US -> US -> US -> DerivInstTys -> DataCon -> (Alt, Alt)
mk1Sum GenericKind
gk US
us US
i ([DataCon] -> US
forall a. [a] -> US
forall (t :: * -> *) a. Foldable t => t a -> US
length [DataCon]
datacons) DerivInstTys
dit DataCon
d
           | (DataCon
d,US
i) <- [DataCon] -> [US] -> [(DataCon, US)]
forall a b. [a] -> [b] -> [(a, b)]
zip [DataCon]
datacons [US
1..] ]

-- Build the sum for a particular constructor
mk1Sum :: GenericKind  -- Generic or Generic1?
       -> US           -- Base for generating unique names
       -> Int          -- The index of this constructor
       -> Int          -- Total number of constructors
       -> DerivInstTys -- Information about the last type argument to Generic(1)
       -> DataCon      -- The data constructor
       -> (Alt,        -- Alternative for the T->Trep "from" function
           Alt)        -- Alternative for the Trep->T "to" function
mk1Sum :: GenericKind
-> US -> US -> US -> DerivInstTys -> DataCon -> (Alt, Alt)
mk1Sum GenericKind
gk US
us US
i US
n dit :: DerivInstTys
dit@(DerivInstTys{dit_rep_tc_args :: DerivInstTys -> [Type]
dit_rep_tc_args = [Type]
tc_args}) DataCon
datacon
  = (Alt
(GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))
from_alt, Alt
(GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))
to_alt)
  where
    gk_ :: GenericKind_DC
gk_ = GenericKind -> DataCon -> [Type] -> GenericKind_DC
gk2gkDC GenericKind
gk DataCon
datacon [Type]
tc_args

    -- Existentials already excluded
    argTys :: [Type]
argTys = DataCon -> DerivInstTys -> [Type]
derivDataConInstArgTys DataCon
datacon DerivInstTys
dit
    n_args :: US
n_args = DataCon -> US
dataConSourceArity DataCon
datacon

    datacon_varTys :: [(RdrName, Type)]
datacon_varTys = [RdrName] -> [Type] -> [(RdrName, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((US -> RdrName) -> [US] -> [RdrName]
forall a b. (a -> b) -> [a] -> [b]
map US -> RdrName
mkGenericLocal [US
us .. US
usUS -> US -> US
forall a. Num a => a -> a -> a
+US
n_argsUS -> US -> US
forall a. Num a => a -> a -> a
-US
1]) [Type]
argTys
    datacon_vars :: [RdrName]
datacon_vars = ((RdrName, Type) -> RdrName) -> [(RdrName, Type)] -> [RdrName]
forall a b. (a -> b) -> [a] -> [b]
map (RdrName, Type) -> RdrName
forall a b. (a, b) -> a
fst [(RdrName, Type)]
datacon_varTys

    datacon_rdr :: RdrName
datacon_rdr  = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
datacon

    from_alt :: (GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))
from_alt     = (RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
datacon_rdr [RdrName]
datacon_vars, LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
from_alt_rhs)
    from_alt_rhs :: LHsExpr GhcPs
from_alt_rhs = US -> US -> LHsExpr GhcPs -> LHsExpr GhcPs
genLR_E US
i US
n (GenericKind_DC -> [(RdrName, Type)] -> LHsExpr GhcPs
mkProd_E GenericKind_DC
gk_ [(RdrName, Type)]
datacon_varTys)

    to_alt :: (GenLocated SrcSpanAnnA (Pat GhcPs), LocatedA (HsExpr GhcPs))
to_alt     = ( US -> US -> LPat GhcPs -> LPat GhcPs
genLR_P US
i US
n (GenericKind -> [(RdrName, Type)] -> LPat GhcPs
mkProd_P GenericKind
gk [(RdrName, Type)]
datacon_varTys)
                 , LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
to_alt_rhs
                 ) -- These M1s are meta-information for the datatype
    to_alt_rhs :: LHsExpr GhcPs
to_alt_rhs = case GenericKind_DC
gk_ of
      GenericKind_DC
Gen0_DC        -> IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP GhcPs
RdrName
datacon_rdr [IdP GhcPs]
[RdrName]
datacon_vars
      Gen1_DC TyVar
argVar -> IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP GhcPs
RdrName
datacon_rdr ([LHsExpr GhcPs] -> LHsExpr GhcPs)
-> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ ((RdrName, Type) -> LHsExpr GhcPs)
-> [(RdrName, Type)] -> [LHsExpr GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (RdrName, Type) -> LHsExpr GhcPs
argTo [(RdrName, Type)]
datacon_varTys
        where
          argTo :: (RdrName, Type) -> LHsExpr GhcPs
argTo (RdrName
var, Type
ty) = Type -> LocatedA (HsExpr GhcPs)
converter Type
ty LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
var where
            converter :: Type -> LocatedA (HsExpr GhcPs)
converter = TyVar
-> ArgTyAlg (LocatedA (HsExpr GhcPs))
-> Type
-> LocatedA (HsExpr GhcPs)
forall a. TyVar -> ArgTyAlg a -> Type -> a
argTyFold TyVar
argVar (ArgTyAlg (LocatedA (HsExpr GhcPs))
 -> Type -> LocatedA (HsExpr GhcPs))
-> ArgTyAlg (LocatedA (HsExpr GhcPs))
-> Type
-> LocatedA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ ArgTyAlg
              {ata_rec0 :: Type -> LocatedA (HsExpr GhcPs)
ata_rec0 = IdP GhcPs -> LHsExpr GhcPs
RdrName -> LocatedA (HsExpr GhcPs)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (RdrName -> LocatedA (HsExpr GhcPs))
-> (Type -> RdrName) -> Type -> LocatedA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> RdrName
unboxRepRDR,
               ata_par1 :: LocatedA (HsExpr GhcPs)
ata_par1 = IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
unPar1_RDR,
               ata_rec1 :: Type -> LocatedA (HsExpr GhcPs)
ata_rec1 = LocatedA (HsExpr GhcPs) -> Type -> LocatedA (HsExpr GhcPs)
forall a b. a -> b -> a
const (LocatedA (HsExpr GhcPs) -> Type -> LocatedA (HsExpr GhcPs))
-> LocatedA (HsExpr GhcPs) -> Type -> LocatedA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
unRec1_RDR,
               ata_comp :: Type -> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
ata_comp = \Type
_ LocatedA (HsExpr GhcPs)
cnv -> (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
fmap_RDR LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
cnv)
                                    LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`nlHsCompose` IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
unComp1_RDR}


-- Generates the L1/R1 sum pattern
genLR_P :: Int -> Int -> LPat GhcPs -> LPat GhcPs
genLR_P :: US -> US -> LPat GhcPs -> LPat GhcPs
genLR_P US
i US
n LPat GhcPs
p
  | US
n US -> US -> Bool
forall a. Eq a => a -> a -> Bool
== US
0       = String -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a. HasCallStack => String -> a
error String
"impossible"
  | US
n US -> US -> Bool
forall a. Eq a => a -> a -> Bool
== US
1       = LPat GhcPs
p
  | US
i US -> US -> Bool
forall a. Ord a => a -> a -> Bool
<= US -> US -> US
forall a. Integral a => a -> a -> a
div US
n US
2 = LPat GhcPs -> LPat GhcPs
forall (p :: Pass).
IsPass p =>
LPat (GhcPass p) -> LPat (GhcPass p)
nlParPat (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName -> [LPat GhcPs] -> LPat GhcPs
nlConPat RdrName
l1DataCon_RDR [US -> US -> LPat GhcPs -> LPat GhcPs
genLR_P US
i     (US -> US -> US
forall a. Integral a => a -> a -> a
div US
n US
2) LPat GhcPs
p]
  | Bool
otherwise    = LPat GhcPs -> LPat GhcPs
forall (p :: Pass).
IsPass p =>
LPat (GhcPass p) -> LPat (GhcPass p)
nlParPat (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName -> [LPat GhcPs] -> LPat GhcPs
nlConPat RdrName
r1DataCon_RDR [US -> US -> LPat GhcPs -> LPat GhcPs
genLR_P (US
iUS -> US -> US
forall a. Num a => a -> a -> a
-US
m) (US
nUS -> US -> US
forall a. Num a => a -> a -> a
-US
m)     LPat GhcPs
p]
                     where m :: US
m = US -> US -> US
forall a. Integral a => a -> a -> a
div US
n US
2

-- Generates the L1/R1 sum expression
genLR_E :: Int -> Int -> LHsExpr GhcPs -> LHsExpr GhcPs
genLR_E :: US -> US -> LHsExpr GhcPs -> LHsExpr GhcPs
genLR_E US
i US
n LHsExpr GhcPs
e
  | US
n US -> US -> Bool
forall a. Eq a => a -> a -> Bool
== US
0       = String -> LocatedA (HsExpr GhcPs)
forall a. HasCallStack => String -> a
error String
"impossible"
  | US
n US -> US -> Bool
forall a. Eq a => a -> a -> Bool
== US
1       = LHsExpr GhcPs
e
  | US
i US -> US -> Bool
forall a. Ord a => a -> a -> Bool
<= US -> US -> US
forall a. Integral a => a -> a -> a
div US
n US
2 = IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
l1DataCon_RDR LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp`
                                            LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
IsPass p =>
LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
nlHsPar (US -> US -> LHsExpr GhcPs -> LHsExpr GhcPs
genLR_E US
i     (US -> US -> US
forall a. Integral a => a -> a -> a
div US
n US
2) LHsExpr GhcPs
e)
  | Bool
otherwise    = IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
r1DataCon_RDR LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp`
                                            LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
IsPass p =>
LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
nlHsPar (US -> US -> LHsExpr GhcPs -> LHsExpr GhcPs
genLR_E (US
iUS -> US -> US
forall a. Num a => a -> a -> a
-US
m) (US
nUS -> US -> US
forall a. Num a => a -> a -> a
-US
m)     LHsExpr GhcPs
e)
                     where m :: US
m = US -> US -> US
forall a. Integral a => a -> a -> a
div US
n US
2

--------------------------------------------------------------------------------
-- Dealing with products
--------------------------------------------------------------------------------

-- Build a product expression
mkProd_E :: GenericKind_DC    -- Generic or Generic1?
         -> [(RdrName, Type)]
                       -- List of variables matched on the lhs and their types
         -> LHsExpr GhcPs   -- Resulting product expression
mkProd_E :: GenericKind_DC -> [(RdrName, Type)] -> LHsExpr GhcPs
mkProd_E GenericKind_DC
gk_ [(RdrName, Type)]
varTys = LHsExpr GhcPs -> LHsExpr GhcPs
mkM1_E ((LocatedA (HsExpr GhcPs)
 -> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> LocatedA (HsExpr GhcPs)
-> [LocatedA (HsExpr GhcPs)]
-> LocatedA (HsExpr GhcPs)
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
forall {p :: Pass}.
(IdGhcP p ~ RdrName, IsPass p) =>
GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
prod (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
u1DataCon_RDR) [LocatedA (HsExpr GhcPs)]
appVars)
                      -- These M1s are meta-information for the constructor
  where
    appVars :: [LocatedA (HsExpr GhcPs)]
appVars = ((RdrName, Type) -> LocatedA (HsExpr GhcPs))
-> [(RdrName, Type)] -> [LocatedA (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map (GenericKind_DC -> (RdrName, Type) -> LHsExpr GhcPs
wrapArg_E GenericKind_DC
gk_) [(RdrName, Type)]
varTys
    prod :: GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
-> LHsExpr (GhcPass p)
prod GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
a GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
b = IdP (GhcPass p)
RdrName
prodDataCon_RDR IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
`nlHsApps` [LHsExpr (GhcPass p)
GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
a,LHsExpr (GhcPass p)
GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
b]

wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr GhcPs
wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr GhcPs
wrapArg_E GenericKind_DC
Gen0_DC          (RdrName
var, Type
ty) = LHsExpr GhcPs -> LHsExpr GhcPs
mkM1_E (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
                            Type -> RdrName
boxRepRDR Type
ty IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
`nlHsVarApps` [IdP GhcPs
RdrName
var]
                         -- This M1 is meta-information for the selector
wrapArg_E (Gen1_DC TyVar
argVar) (RdrName
var, Type
ty) = LHsExpr GhcPs -> LHsExpr GhcPs
mkM1_E (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
                            Type -> LocatedA (HsExpr GhcPs)
converter Type
ty LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
var
                         -- This M1 is meta-information for the selector
  where converter :: Type -> LocatedA (HsExpr GhcPs)
converter = TyVar
-> ArgTyAlg (LocatedA (HsExpr GhcPs))
-> Type
-> LocatedA (HsExpr GhcPs)
forall a. TyVar -> ArgTyAlg a -> Type -> a
argTyFold TyVar
argVar (ArgTyAlg (LocatedA (HsExpr GhcPs))
 -> Type -> LocatedA (HsExpr GhcPs))
-> ArgTyAlg (LocatedA (HsExpr GhcPs))
-> Type
-> LocatedA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ ArgTyAlg
          {ata_rec0 :: Type -> LocatedA (HsExpr GhcPs)
ata_rec0 = IdP GhcPs -> LHsExpr GhcPs
RdrName -> LocatedA (HsExpr GhcPs)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (RdrName -> LocatedA (HsExpr GhcPs))
-> (Type -> RdrName) -> Type -> LocatedA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> RdrName
boxRepRDR,
           ata_par1 :: LocatedA (HsExpr GhcPs)
ata_par1 = IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
par1DataCon_RDR,
           ata_rec1 :: Type -> LocatedA (HsExpr GhcPs)
ata_rec1 = LocatedA (HsExpr GhcPs) -> Type -> LocatedA (HsExpr GhcPs)
forall a b. a -> b -> a
const (LocatedA (HsExpr GhcPs) -> Type -> LocatedA (HsExpr GhcPs))
-> LocatedA (HsExpr GhcPs) -> Type -> LocatedA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
rec1DataCon_RDR,
           ata_comp :: Type -> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
ata_comp = \Type
_ LocatedA (HsExpr GhcPs)
cnv -> IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
comp1DataCon_RDR LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`nlHsCompose`
                                  (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
fmap_RDR LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
cnv)}

boxRepRDR :: Type -> RdrName
boxRepRDR :: Type -> RdrName
boxRepRDR = RdrName
-> ((RdrName, RdrName) -> RdrName)
-> Maybe (RdrName, RdrName)
-> RdrName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe RdrName
k1DataCon_RDR (RdrName, RdrName) -> RdrName
forall a b. (a, b) -> a
fst (Maybe (RdrName, RdrName) -> RdrName)
-> (Type -> Maybe (RdrName, RdrName)) -> Type -> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe (RdrName, RdrName)
unboxedRepRDRs

unboxRepRDR :: Type -> RdrName
unboxRepRDR :: Type -> RdrName
unboxRepRDR = RdrName
-> ((RdrName, RdrName) -> RdrName)
-> Maybe (RdrName, RdrName)
-> RdrName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe RdrName
unK1_RDR (RdrName, RdrName) -> RdrName
forall a b. (a, b) -> b
snd (Maybe (RdrName, RdrName) -> RdrName)
-> (Type -> Maybe (RdrName, RdrName)) -> Type -> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe (RdrName, RdrName)
unboxedRepRDRs

-- Retrieve the RDRs associated with each URec data family instance
-- constructor. See Note [Generics and unlifted types]
unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName)
unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName)
unboxedRepRDRs Type
ty
  | Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
addrPrimTy   = (RdrName, RdrName) -> Maybe (RdrName, RdrName)
forall a. a -> Maybe a
Just (RdrName
uAddrDataCon_RDR,   RdrName
uAddrHash_RDR)
  | Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
charPrimTy   = (RdrName, RdrName) -> Maybe (RdrName, RdrName)
forall a. a -> Maybe a
Just (RdrName
uCharDataCon_RDR,   RdrName
uCharHash_RDR)
  | Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
doublePrimTy = (RdrName, RdrName) -> Maybe (RdrName, RdrName)
forall a. a -> Maybe a
Just (RdrName
uDoubleDataCon_RDR, RdrName
uDoubleHash_RDR)
  | Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
floatPrimTy  = (RdrName, RdrName) -> Maybe (RdrName, RdrName)
forall a. a -> Maybe a
Just (RdrName
uFloatDataCon_RDR,  RdrName
uFloatHash_RDR)
  | Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
intPrimTy    = (RdrName, RdrName) -> Maybe (RdrName, RdrName)
forall a. a -> Maybe a
Just (RdrName
uIntDataCon_RDR,    RdrName
uIntHash_RDR)
  | Type
ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
wordPrimTy   = (RdrName, RdrName) -> Maybe (RdrName, RdrName)
forall a. a -> Maybe a
Just (RdrName
uWordDataCon_RDR,   RdrName
uWordHash_RDR)
  | Bool
otherwise          = Maybe (RdrName, RdrName)
forall a. Maybe a
Nothing

-- Build a product pattern
mkProd_P :: GenericKind       -- Gen0 or Gen1
         -> [(RdrName, Type)] -- List of variables to match,
                              --   along with their types
         -> LPat GhcPs      -- Resulting product pattern
mkProd_P :: GenericKind -> [(RdrName, Type)] -> LPat GhcPs
mkProd_P GenericKind
gk [(RdrName, Type)]
varTys = LPat GhcPs -> LPat GhcPs
mkM1_P ((GenLocated SrcSpanAnnA (Pat GhcPs)
 -> GenLocated SrcSpanAnnA (Pat GhcPs)
 -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
prod (RdrName -> LPat GhcPs
nlNullaryConPat RdrName
u1DataCon_RDR) [GenLocated SrcSpanAnnA (Pat GhcPs)]
appVars)
                     -- These M1s are meta-information for the constructor
  where
    appVars :: [GenLocated SrcSpanAnnA (Pat GhcPs)]
appVars = (RdrName -> Type -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> [(RdrName, Type)] -> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a b c. (a -> b -> c) -> [(a, b)] -> [c]
unzipWith (GenericKind -> RdrName -> Type -> LPat GhcPs
wrapArg_P GenericKind
gk) [(RdrName, Type)]
varTys
    prod :: GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs) -> LPat GhcPs
prod GenLocated SrcSpanAnnA (Pat GhcPs)
a GenLocated SrcSpanAnnA (Pat GhcPs)
b = LPat GhcPs -> LPat GhcPs
forall (p :: Pass).
IsPass p =>
LPat (GhcPass p) -> LPat (GhcPass p)
nlParPat (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName
prodDataCon_RDR RdrName -> [LPat GhcPs] -> LPat GhcPs
`nlConPat` [LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
a,LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
b]

wrapArg_P :: GenericKind -> RdrName -> Type -> LPat GhcPs
wrapArg_P :: GenericKind -> RdrName -> Type -> LPat GhcPs
wrapArg_P GenericKind
Gen0 RdrName
v Type
ty = LPat GhcPs -> LPat GhcPs
mkM1_P (LPat GhcPs -> LPat GhcPs
forall (p :: Pass).
IsPass p =>
LPat (GhcPass p) -> LPat (GhcPass p)
nlParPat (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ Type -> RdrName
boxRepRDR Type
ty RdrName -> [RdrName] -> LPat GhcPs
`nlConVarPat` [RdrName
v])
                   -- This M1 is meta-information for the selector
wrapArg_P GenericKind
Gen1 RdrName
v Type
_  = LPat GhcPs -> LPat GhcPs
forall (p :: Pass).
IsPass p =>
LPat (GhcPass p) -> LPat (GhcPass p)
nlParPat (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName
m1DataCon_RDR RdrName -> [RdrName] -> LPat GhcPs
`nlConVarPat` [RdrName
v]

mkGenericLocal :: US -> RdrName
mkGenericLocal :: US -> RdrName
mkGenericLocal US
u = FastString -> RdrName
mkVarUnqual (String -> FastString
mkFastString (String
"g" String -> String -> String
forall a. [a] -> [a] -> [a]
++ US -> String
forall a. Show a => a -> String
show US
u))

x_RDR :: RdrName
x_RDR :: RdrName
x_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"x")

x_Expr :: LHsExpr GhcPs
x_Expr :: LHsExpr GhcPs
x_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
x_RDR

x_Pat :: LPat GhcPs
x_Pat :: LPat GhcPs
x_Pat = IdP GhcPs -> LPat GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat IdP GhcPs
RdrName
x_RDR

mkM1_E :: LHsExpr GhcPs -> LHsExpr GhcPs
mkM1_E :: LHsExpr GhcPs -> LHsExpr GhcPs
mkM1_E LHsExpr GhcPs
e = IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
m1DataCon_RDR LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr GhcPs
e

mkM1_P :: LPat GhcPs -> LPat GhcPs
mkM1_P :: LPat GhcPs -> LPat GhcPs
mkM1_P LPat GhcPs
p = LPat GhcPs -> LPat GhcPs
forall (p :: Pass).
IsPass p =>
LPat (GhcPass p) -> LPat (GhcPass p)
nlParPat (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName
m1DataCon_RDR RdrName -> [LPat GhcPs] -> LPat GhcPs
`nlConPat` [LPat GhcPs
p]

nlHsCompose :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsCompose :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsCompose LHsExpr GhcPs
x LHsExpr GhcPs
y = IdP GhcPs
RdrName
compose_RDR IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
`nlHsApps` [LHsExpr GhcPs
x, LHsExpr GhcPs
y]

-- | Variant of foldr for producing balanced lists
foldBal :: (a -> a -> a) -> a -> [a] -> a
{-# INLINE foldBal #-} -- inlined to produce specialised code for each op
foldBal :: forall a. (a -> a -> a) -> a -> [a] -> a
foldBal a -> a -> a
op0 a
x0 [a]
xs0 = (a -> a -> a) -> a -> US -> [a] -> a
forall {t}. (t -> t -> t) -> t -> US -> [t] -> t
fold_bal a -> a -> a
op0 a
x0 ([a] -> US
forall a. [a] -> US
forall (t :: * -> *) a. Foldable t => t a -> US
length [a]
xs0) [a]
xs0
  where
    fold_bal :: (t -> t -> t) -> t -> US -> [t] -> t
fold_bal t -> t -> t
op t
x !US
n [t]
xs = case [t]
xs of
      []  -> t
x
      [t
a] -> t
a
      [t]
_   -> let !nl :: US
nl = US
n US -> US -> US
forall a. Integral a => a -> a -> a
`div` US
2
                 !nr :: US
nr = US
n US -> US -> US
forall a. Num a => a -> a -> a
- US
nl
                 ([t]
l,[t]
r) = US -> [t] -> ([t], [t])
forall a. US -> [a] -> ([a], [a])
splitAt US
nl [t]
xs
             in (t -> t -> t) -> t -> US -> [t] -> t
fold_bal t -> t -> t
op t
x US
nl [t]
l
                t -> t -> t
`op` (t -> t -> t) -> t -> US -> [t] -> t
fold_bal t -> t -> t
op t
x US
nr [t]
r

{-
Note [Generics and unlifted types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Normally, all constants are marked with K1/Rec0. The exception to this rule is
when a data constructor has an unlifted argument (e.g., Int#, Char#, etc.). In
that case, we must use a data family instance of URec (from GHC.Generics) to
mark it. As a result, before we can generate K1 or unK1, we must first check
to see if the type is actually one of the unlifted types for which URec has a
data family instance; if so, we generate that instead.

See wiki:commentary/compiler/generic-deriving#handling-unlifted-types for more
details on why URec is implemented the way it is.

Note [Generating a correctly typed Rep instance]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tc_mkRepTy derives the RHS of the Rep(1) type family instance when deriving
Generic(1). For example, given the following data declaration:

    data Foo a = MkFoo a
      deriving stock Generic

tc_mkRepTy would generate the `Rec0 a` portion of this instance:

    instance Generic (Foo a) where
      type Rep (Foo a) = Rec0 a
      ...

(The full `Rep` instance is more complicated than this, but we have simplified
it for presentation purposes.)

`tc_mkRepTy` figures out the field types to use in the RHS by inspecting a
DerivInstTys, which contains the instantiated field types for each data
constructor. (See Note [Instantiating field types in stock deriving] for a
description of how this works.) As a result, `tc_mkRepTy` "just works" even
when dealing with StandaloneDeriving, such as in this example:

    deriving stock instance Generic (Foo Int)
      ===>
    instance Generic (Foo Int) where
      type Rep (Foo Int) = Rec0 Int -- The `a` has been instantiated here

A wrinkle in all of this: what happens when deriving a Generic1 instance where
the last type variable appears in a type synonym that discards it? That is,
what should happen in this example (taken from #15012)?

    type FakeOut a = Int
    data T a = MkT (FakeOut a)
      deriving Generic1

MkT is a particularly wily data constructor. Although the last type variable
`a` technically appears in `FakeOut a`, it's just a smokescreen, as `FakeOut a`
simply expands to `Int`. As a result, `MkT` doesn't really *use* the last type
variable. Therefore, T's `Rep` instance would use Rec0 to represent MkT's
field. But we must be careful not to produce code like this:

   instance Generic1 T where
     type Rep1 T = Rec0 (FakeOut a)
     ...

Oh no! Now we have `a` on the RHS, but it's completely unbound. This can cause
issues like what was observed in #15012. To avoid this, we ensure that `a` is
instantiated to Any:

   instance Generic1 T where
     type Rep1 T = Rec0 (FakeOut Any)
     ...

And now all is good.

Alternatively, we could have avoided this problem by expanding all type
synonyms on the RHSes of Rep1 instances. But we might blow up the size of
these types even further by doing this, so we choose not to do so.

Note [Handling kinds in a Rep instance]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Because Generic1 is poly-kinded, the representation types were generalized to
be kind-polymorphic as well. As a result, tc_mkRepTy must explicitly apply
the kind of the instance being derived to all the representation type
constructors. For instance, if you have

    data Empty (a :: k) = Empty deriving Generic1

Then the generated code is now approximately (with -fprint-explicit-kinds
syntax):

    instance Generic1 k (Empty k) where
      type Rep1 k (Empty k) = U1 k

Most representation types have only one kind variable, making them easy to deal
with. The only non-trivial case is (:.:), which is only used in Generic1
instances:

    newtype (:.:) (f :: k2 -> *) (g :: k1 -> k2) (p :: k1) =
        Comp1 { unComp1 :: f (g p) }

Here, we do something a bit counter-intuitive: we make k1 be the kind of the
instance being derived, and we always make k2 be *. Why *? It's because
the code that GHC generates using (:.:) is always of the form x :.: Rec1 y
for some types x and y. In other words, the second type to which (:.:) is
applied always has kind k -> *, for some kind k, so k2 cannot possibly be
anything other than * in a generated Generic1 instance.

Note [Generics compilation speed tricks]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Deriving Generic(1) is known to have a large constant factor during
compilation, which contributes to noticeable compilation slowdowns when
deriving Generic(1) for large datatypes (see #5642).

To ease the pain, there is a trick one can play when generating definitions for
to(1) and from(1). If you have a datatype like:

  data Letter = A | B | C | D

then a naïve Generic instance for Letter would be:

  instance Generic Letter where
    type Rep Letter = D1 ('MetaData ...) ...

    to (M1 (L1 (L1 (M1 U1)))) = A
    to (M1 (L1 (R1 (M1 U1)))) = B
    to (M1 (R1 (L1 (M1 U1)))) = C
    to (M1 (R1 (R1 (M1 U1)))) = D

    from A = M1 (L1 (L1 (M1 U1)))
    from B = M1 (L1 (R1 (M1 U1)))
    from C = M1 (R1 (L1 (M1 U1)))
    from D = M1 (R1 (R1 (M1 U1)))

Notice that in every LHS pattern-match of the 'to' definition, and in every RHS
expression in the 'from' definition, the topmost constructor is M1. This
corresponds to the datatype-specific metadata (the D1 in the Rep Letter
instance). But this is wasteful from a typechecking perspective, since this
definition requires GHC to typecheck an application of M1 in every single case,
leading to an O(n) increase in the number of coercions the typechecker has to
solve, which in turn increases allocations and degrades compilation speed.

Luckily, since the topmost M1 has the exact same type across every case, we can
factor it out reduce the typechecker's burden:

  instance Generic Letter where
    type Rep Letter = D1 ('MetaData ...) ...

    to (M1 x) = case x of
      L1 (L1 (M1 U1)) -> A
      L1 (R1 (M1 U1)) -> B
      R1 (L1 (M1 U1)) -> C
      R1 (R1 (M1 U1)) -> D

    from x = M1 (case x of
      A -> L1 (L1 (M1 U1))
      B -> L1 (R1 (M1 U1))
      C -> R1 (L1 (M1 U1))
      D -> R1 (R1 (M1 U1)))

A simple change, but one that pays off, since it goes turns an O(n) amount of
coercions to an O(1) amount.

Note [Generics performance tricks]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Generics-based algorithms tend to rely on GHC optimizing away the intermediate
representation for optimal performance. However, the default unfolding threshold
is usually too small for GHC to do that.

The recommended approach thus far was to increase unfolding threshold, but this
makes GHC inline more aggressively in general, whereas it should only be more
aggressive with generics-based code.

The solution is to use a heuristic that'll annotate Generic class methods with
INLINE[1] pragmas (the explicit phase is used to give users phase control as
they can annotate their functions with INLINE[2] or INLINE[0] if appropriate).

The current heuristic was chosen by looking at how annotating Generic methods
INLINE[1] helps with optimal code generation for several types of generic
algorithms:

* Round trip through the generic representation.

* Generation of NFData instances.

* Generation of field lenses.

The experimentation was done by picking data types having N constructors with M
fields each and using their derived Generic instances to generate code with the
above algorithms.

The results are threshold values for N and M (contained in
`mkBindsRep.inlining_useful`) for which inlining is beneficial, i.e. it usually
leads to performance improvements at both compile time (the simplifier has to do
more work, but then there's much less code left for subsequent phases to work
with) and run time (the generic representation of a data type is optimized
away).

The T11068 test case, which includes the algorithms mentioned above, tests that
the generic representations of several data types optimize away using the
threshold values in `mkBindsRep.inlining_useful`.

If one uses threshold values higher what is found in
`mkBindsRep.inlining_useful`, then annotating Generic class methods with INLINE
pragmas tends to be at best useless and at worst lead to code size blowup
without runtime performance improvements.
-}