{-
(c) The University of Glasgow 2011

-}

{-# LANGUAGE CPP, ScopedTypeVariables, TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}

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

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

import GHC.Prelude

import GHC.Hs
import GHC.Core.Type
import GHC.Tc.Utils.TcType
import GHC.Tc.Deriv.Generate
import GHC.Tc.Deriv.Functor
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom )
import GHC.Core.Multiplicity
import GHC.Tc.Instance.Family
import GHC.Unit.Module ( moduleName, moduleNameFS
                        , moduleUnit, unitFS, getModule )
import GHC.Iface.Env    ( newGlobalBinder )
import GHC.Types.Name hiding ( varName )
import GHC.Types.Name.Reader
import GHC.Types.Basic
import GHC.Builtin.Types.Prim
import GHC.Builtin.Types
import GHC.Builtin.Names
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Monad
import GHC.Driver.Types
import GHC.Utils.Error( Validity(..), andValid )
import GHC.Types.SrcLoc
import GHC.Data.Bag
import GHC.Types.Var.Env
import GHC.Types.Var.Set (elemVarSet)
import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Utils.Misc

import Control.Monad (mplus)
import Data.List (zip4, partition)
import Data.Maybe (isJust)

#include "HsVersions.h"

{-
************************************************************************
*                                                                      *
\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 -> TyCon -> [Type]
                 -> TcM (LHsBinds GhcPs, FamInst)
gen_Generic_binds :: GenericKind -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, FamInst)
gen_Generic_binds GenericKind
gk TyCon
tc [Type]
inst_tys = do
  FamInst
repTyInsts <- GenericKind -> TyCon -> [Type] -> TcM FamInst
tc_mkRepFamInsts GenericKind
gk TyCon
tc [Type]
inst_tys
  (LHsBinds GhcPs, FamInst) -> TcM (LHsBinds GhcPs, FamInst)
forall (m :: * -> *) a. Monad m => a -> m a
return (GenericKind -> TyCon -> LHsBinds GhcPs
mkBindsRep GenericKind
gk TyCon
tc, FamInst
repTyInsts)

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

get_gen1_constrained_tys :: TyVar -> Type -> [Type]
-- 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.
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 :: forall a.
(Type -> a) -> a -> (Type -> a) -> (Type -> a -> a) -> ArgTyAlg a
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".

  (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 :: TyCon -> Validity
-- 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 :: TyCon -> Validity
canDoGenerics TyCon
tc
  = [Validity] -> Validity
mergeErrors (
          -- Check (b) from Note [Requirements for deriving Generic and Rep].
              (if (Bool -> Bool
not ([Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TyCon -> [Type]
tyConStupidTheta TyCon
tc)))
                then (MsgDoc -> Validity
NotValid (MsgDoc
tc_name MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"must not have a datatype context"))
                else Validity
IsValid)
          -- See comment below
            Validity -> [Validity] -> [Validity]
forall a. a -> [a] -> [a]
: ((DataCon -> Validity) -> [DataCon] -> [Validity]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Validity
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 :: MsgDoc
tc_name = TyCon -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (TyCon -> MsgDoc) -> TyCon -> MsgDoc
forall a b. (a -> b) -> a -> b
$ 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
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 ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing ([Scaled Type] -> [Type]) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ DataCon -> [Scaled Type]
dataConOrigArgTys DataCon
dc))
                  then (MsgDoc -> Validity
NotValid (DataCon -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr DataCon
dc MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text
                    String
"must not have exotic unlifted or polymorphic arguments"))
                  else (if (Bool -> Bool
not (DataCon -> Bool
isVanillaDataCon DataCon
dc))
                          then (MsgDoc -> Validity
NotValid (DataCon -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr DataCon
dc MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"must be a vanilla data constructor"))
                          else Validity
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 = (HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType 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] -> Validity
mergeErrors :: [Validity] -> Validity
mergeErrors []             = Validity
IsValid
mergeErrors (NotValid MsgDoc
s:[Validity]
t) = case [Validity] -> Validity
mergeErrors [Validity]
t of
  Validity
IsValid     -> MsgDoc -> Validity
NotValid MsgDoc
s
  NotValid MsgDoc
s' -> MsgDoc -> Validity
NotValid (MsgDoc
s MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text String
", and" MsgDoc -> MsgDoc -> MsgDoc
$$ MsgDoc
s')
mergeErrors (Validity
IsValid : [Validity]
t) = [Validity] -> Validity
mergeErrors [Validity]
t

-- 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
_ccdg1_errors   :: Validity   -- 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 :: TyCon -> Validity
canDoGenerics1 :: TyCon -> Validity
canDoGenerics1 TyCon
rep_tc =
  TyCon -> Validity
canDoGenerics TyCon
rep_tc Validity -> Validity -> Validity
`andValid` Validity
additionalChecks
  where
    additionalChecks :: Validity
additionalChecks
        -- check (d) from Note [Requirements for deriving Generic and Rep]
      | [TyVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TyCon -> [TyVar]
tyConTyVars TyCon
rep_tc) = MsgDoc -> Validity
NotValid (MsgDoc -> Validity) -> MsgDoc -> Validity
forall a b. (a -> b) -> a -> b
$
          String -> MsgDoc
text String
"Data type" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (TyCon -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr TyCon
rep_tc)
      MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"must have some type parameters"

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

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

    bad :: DataCon -> SDoc -> SDoc
    bad :: DataCon -> MsgDoc -> MsgDoc
bad DataCon
con MsgDoc
msg = String -> MsgDoc
text String
"Constructor" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (DataCon -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr DataCon
con) MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
msg

    check_vanilla :: DataCon -> Validity
    check_vanilla :: DataCon -> Validity
check_vanilla DataCon
con | DataCon -> Bool
isVanillaDataCon DataCon
con = Validity
IsValid
                      | Bool
otherwise            = MsgDoc -> Validity
NotValid (DataCon -> MsgDoc -> MsgDoc
bad DataCon
con MsgDoc
existential)

    bmzero :: Check_for_CanDoGenerics1
bmzero      = Bool -> Validity -> Check_for_CanDoGenerics1
CCDG1 Bool
False Validity
IsValid
    bmbad :: DataCon -> MsgDoc -> Check_for_CanDoGenerics1
bmbad DataCon
con MsgDoc
s = Bool -> Validity -> Check_for_CanDoGenerics1
CCDG1 Bool
True (Validity -> Check_for_CanDoGenerics1)
-> Validity -> Check_for_CanDoGenerics1
forall a b. (a -> b) -> a -> b
$ MsgDoc -> Validity
NotValid (MsgDoc -> Validity) -> MsgDoc -> Validity
forall a b. (a -> b) -> a -> b
$ DataCon -> MsgDoc -> MsgDoc
bad DataCon
con MsgDoc
s
    bmplus :: Check_for_CanDoGenerics1
-> Check_for_CanDoGenerics1 -> Check_for_CanDoGenerics1
bmplus (CCDG1 Bool
b1 Validity
m1) (CCDG1 Bool
b2 Validity
m2) = Bool -> Validity -> Check_for_CanDoGenerics1
CCDG1 (Bool
b1 Bool -> Bool -> Bool
|| Bool
b2) (Validity
m1 Validity -> Validity -> Validity
`andValid` Validity
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 :: forall a.
a
-> a
-> a
-> (a -> a -> a)
-> (TyCon -> [a] -> a)
-> (Type -> Type -> a -> a)
-> a
-> (TyVar -> a -> a)
-> FFoldType a
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 -> if (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 ([Check_for_CanDoGenerics1] -> [Check_for_CanDoGenerics1]
forall a. [a] -> [a]
init [Check_for_CanDoGenerics1]
components)
                                  then DataCon -> MsgDoc -> Check_for_CanDoGenerics1
bmbad DataCon
con MsgDoc
wrong_arg
                                  else (Check_for_CanDoGenerics1
 -> Check_for_CanDoGenerics1 -> Check_for_CanDoGenerics1)
-> Check_for_CanDoGenerics1
-> [Check_for_CanDoGenerics1]
-> Check_for_CanDoGenerics1
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 -> MsgDoc -> Check_for_CanDoGenerics1
bmbad DataCon
con MsgDoc
wrong_arg
          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 -> MsgDoc -> Check_for_CanDoGenerics1
bmbad DataCon
con MsgDoc
wrong_arg
      , 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 -> Check_for_CanDoGenerics1
CCDG1 Bool
True Validity
IsValid


    existential :: MsgDoc
existential = String -> MsgDoc
text String
"must not have existential arguments"
    wrong_arg :: MsgDoc
wrong_arg   = String -> MsgDoc
text String
"applies a type to an argument involving the last parameter"
               MsgDoc -> MsgDoc -> MsgDoc
$$ String -> MsgDoc
text String
"but the applied type is not of kind * -> *"

{-
************************************************************************
*                                                                      *
\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

-- as above, but with a payload of the TyCon's name for "the" parameter
data GenericKind_ = Gen0_ | Gen1_ TyVar

-- as above, but using a single datacon's name for "the" parameter
data GenericKind_DC = Gen0_DC | Gen1_DC TyVar

forgetArgVar :: GenericKind_DC -> GenericKind
forgetArgVar :: GenericKind_DC -> GenericKind
forgetArgVar GenericKind_DC
Gen0_DC   = GenericKind
Gen0
forgetArgVar Gen1_DC{} = GenericKind
Gen1

-- When working only within a single datacon, "the" parameter's name should
-- match that datacon's name for it.
gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC
gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC
gk2gkDC GenericKind_
Gen0_   DataCon
_ = GenericKind_DC
Gen0_DC
gk2gkDC Gen1_{} DataCon
d = TyVar -> GenericKind_DC
Gen1_DC (TyVar -> GenericKind_DC) -> TyVar -> GenericKind_DC
forall a b. (a -> b) -> a -> b
$ [TyVar] -> TyVar
forall a. [a] -> a
last ([TyVar] -> TyVar) -> [TyVar] -> TyVar
forall a b. (a -> b) -> a -> b
$ DataCon -> [TyVar]
dataConUnivTyVars DataCon
d


-- Bindings for the Generic instance
mkBindsRep :: GenericKind -> TyCon -> LHsBinds GhcPs
mkBindsRep :: GenericKind -> TyCon -> LHsBinds GhcPs
mkBindsRep GenericKind
gk TyCon
tycon =
    LHsBind GhcPs -> LHsBinds GhcPs
forall a. a -> Bag a
unitBag (Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBind (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
from01_RDR) [LMatch GhcPs (LHsExpr GhcPs)
from_eqn])
  LHsBinds GhcPs -> LHsBinds GhcPs -> LHsBinds GhcPs
forall a. Bag a -> Bag a -> Bag a
`unionBags`
    LHsBind GhcPs -> LHsBinds GhcPs
forall a. a -> Bag a
unitBag (Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBind (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
to01_RDR) [LMatch GhcPs (LHsExpr GhcPs)
to_eqn])
      where
        -- 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 (LHsExpr GhcPs)
from_eqn = LPat GhcPs -> LHsExpr GhcPs -> LMatch GhcPs (LHsExpr GhcPs)
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
x_Pat (LHsExpr GhcPs -> LMatch GhcPs (LHsExpr GhcPs))
-> LHsExpr GhcPs -> LMatch GhcPs (LHsExpr 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 (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
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)]
from_matches
        to_eqn :: LMatch GhcPs (LHsExpr GhcPs)
to_eqn   = LPat GhcPs -> LHsExpr GhcPs -> LMatch GhcPs (LHsExpr GhcPs)
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt (LPat GhcPs -> LPat GhcPs
mkM1_P LPat GhcPs
x_Pat) (LHsExpr GhcPs -> LMatch GhcPs (LHsExpr GhcPs))
-> LHsExpr GhcPs -> LMatch 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)]
to_matches

        from_matches :: [LMatch GhcPs (LHsExpr GhcPs)]
from_matches  = [LPat GhcPs -> LHsExpr GhcPs -> LMatch GhcPs (LHsExpr GhcPs)
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt Located (Pat GhcPs)
LPat GhcPs
pat LHsExpr GhcPs
rhs | (Located (Pat GhcPs)
pat,LHsExpr GhcPs
rhs) <- [(Located (Pat GhcPs), LHsExpr GhcPs)]
[Alt]
from_alts]
        to_matches :: [LMatch GhcPs (LHsExpr GhcPs)]
to_matches    = [LPat GhcPs -> LHsExpr GhcPs -> LMatch GhcPs (LHsExpr GhcPs)
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt Located (Pat GhcPs)
LPat GhcPs
pat LHsExpr GhcPs
rhs | (Located (Pat GhcPs)
pat,LHsExpr GhcPs
rhs) <- [(Located (Pat GhcPs), LHsExpr GhcPs)]
[Alt]
to_alts  ]
        loc :: SrcSpan
loc           = SrcLoc -> SrcSpan
srcLocSpan (TyCon -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc TyCon
tycon)
        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]
        ([(Located (Pat GhcPs), LHsExpr GhcPs)]
[Alt]
from_alts, [(Located (Pat GhcPs), LHsExpr GhcPs)]
[Alt]
to_alts) = GenericKind_ -> US -> [DataCon] -> ([Alt], [Alt])
mkSum GenericKind_
gk_ (US
1 :: US) [DataCon]
datacons
          where gk_ :: GenericKind_
gk_ = case GenericKind
gk of
                  GenericKind
Gen0 -> GenericKind_
Gen0_
                  GenericKind
Gen1 -> ASSERT(tyvars `lengthAtLeast` 1)
                          TyVar -> GenericKind_
Gen1_ ([TyVar] -> TyVar
forall a. [a] -> a
last [TyVar]
tyvars)
                    where tyvars :: [TyVar]
tyvars = TyCon -> [TyVar]
tyConTyVars TyCon
tycon

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

tc_mkRepFamInsts :: GenericKind   -- Gen0 or Gen1
                 -> TyCon         -- The type to generate representation for
                 -> [Type]        -- The type(s) to which Generic(1) is applied
                                  -- in the generated instance
                 -> TcM FamInst   -- Generated representation0 coercion
tc_mkRepFamInsts :: GenericKind -> TyCon -> [Type] -> TcM FamInst
tc_mkRepFamInsts GenericKind
gk TyCon
tycon [Type]
inst_tys =
       -- 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)
       TyCon
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

     ; FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs

     ; 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 -> *
           (Type
arg_ki, Type
inst_ty) = case (GenericKind
gk, [Type]
inst_tys) of
             (GenericKind
Gen0, [Type
inst_t])        -> (Type
liftedTypeKind, Type
inst_t)
             (GenericKind
Gen1, [Type
arg_k, Type
inst_t]) -> (Type
arg_k,          Type
inst_t)
             (GenericKind, [Type])
_ -> String -> MsgDoc -> (Type, Type)
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"tc_mkRepFamInsts" ([Type] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Type]
inst_tys)

     ; let mbFamInst :: Maybe (TyCon, [Type])
mbFamInst         = TyCon -> Maybe (TyCon, [Type])
tyConFamInst_maybe TyCon
tycon
           -- If we're examining a data family instance, we grab the parent
           -- TyCon (ptc) and use it to determine the type arguments
           -- (inst_args) for the data family *instance*'s type variables.
           ptc :: TyCon
ptc               = TyCon
-> ((TyCon, [Type]) -> TyCon) -> Maybe (TyCon, [Type]) -> TyCon
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TyCon
tycon (TyCon, [Type]) -> TyCon
forall a b. (a, b) -> a
fst Maybe (TyCon, [Type])
mbFamInst
           (TyCon
_, [Type]
inst_args, Coercion
_) = FamInstEnvs -> TyCon -> [Type] -> (TyCon, [Type], Coercion)
tcLookupDataFamInst FamInstEnvs
fam_envs TyCon
ptc ([Type] -> (TyCon, [Type], Coercion))
-> [Type] -> (TyCon, [Type], Coercion)
forall a b. (a -> b) -> a -> b
$ (TyCon, [Type]) -> [Type]
forall a b. (a, b) -> b
snd
                                 ((TyCon, [Type]) -> [Type]) -> (TyCon, [Type]) -> [Type]
forall a b. (a -> b) -> a -> b
$ Type -> (TyCon, [Type])
tcSplitTyConApp Type
inst_ty

     ; let -- `tyvars` = [a,b]
           ([TyVar]
tyvars, GenericKind_
gk_) = case GenericKind
gk of
             GenericKind
Gen0 -> ([TyVar]
all_tyvars, GenericKind_
Gen0_)
             GenericKind
Gen1 -> ASSERT(not $ null all_tyvars)
                     ([TyVar] -> [TyVar]
forall a. [a] -> [a]
init [TyVar]
all_tyvars, TyVar -> GenericKind_
Gen1_ (TyVar -> GenericKind_) -> TyVar -> GenericKind_
forall a b. (a -> b) -> a -> b
$ [TyVar] -> TyVar
forall a. [a] -> a
last [TyVar]
all_tyvars)
             where all_tyvars :: [TyVar]
all_tyvars = TyCon -> [TyVar]
tyConTyVars TyCon
tycon

       -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
     ; Type
repTy <- GenericKind_ -> TyCon -> Type -> TcM Type
tc_mkRepTy GenericKind_
gk_ TyCon
tycon Type
arg_ki

       -- `rep_name` is a name we generate for the synonym
     ; Module
mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
     ; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
     ; let tc_occ :: OccName
tc_occ  = Name -> OccName
nameOccName (TyCon -> Name
tyConName TyCon
tycon)
           rep_occ :: OccName
rep_occ = case GenericKind
gk of GenericKind
Gen0 -> OccName -> OccName
mkGenR OccName
tc_occ; GenericKind
Gen1 -> OccName -> OccName
mkGen1R OccName
tc_occ
     ; Name
rep_name <- Module -> OccName -> SrcSpan -> TcRnIf TcGblEnv TcLclEnv Name
forall a b. Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder Module
mod OccName
rep_occ SrcSpan
loc

       -- We make sure to substitute the tyvars with their user-supplied
       -- type arguments before generating the Rep/Rep1 instance, since some
       -- of the tyvars might have been instantiated when deriving.
       -- See Note [Generating a correctly typed Rep instance].
     ; let ([TyVar]
env_tyvars, [Type]
env_inst_args)
             = case GenericKind_
gk_ of
                 GenericKind_
Gen0_ -> ([TyVar]
tyvars, [Type]
inst_args)
                 Gen1_ TyVar
last_tv
                          -- See the "wrinkle" in
                          -- Note [Generating a correctly typed Rep instance]
                       -> ( TyVar
last_tv TyVar -> [TyVar] -> [TyVar]
forall a. a -> [a] -> [a]
: [TyVar]
tyvars
                          , Type -> Type
anyTypeOfKind (TyVar -> Type
tyVarKind TyVar
last_tv) Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
inst_args )
           env :: TvSubstEnv
env        = [TyVar] -> [Type] -> TvSubstEnv
HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv
zipTyEnv [TyVar]
env_tyvars [Type]
env_inst_args
           in_scope :: InScopeSet
in_scope   = VarSet -> InScopeSet
mkInScopeSet ([Type] -> VarSet
tyCoVarsOfTypes [Type]
inst_tys)
           subst :: TCvSubst
subst      = InScopeSet -> TvSubstEnv -> TCvSubst
mkTvSubst InScopeSet
in_scope TvSubstEnv
env
           repTy' :: Type
repTy'     = TCvSubst -> Type -> Type
substTyUnchecked  TCvSubst
subst Type
repTy
           tcv' :: [TyVar]
tcv'       = Type -> [TyVar]
tyCoVarsOfTypeList Type
inst_ty
           ([TyVar]
tv', [TyVar]
cv') = (TyVar -> Bool) -> [TyVar] -> ([TyVar], [TyVar])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition TyVar -> Bool
isTyVar [TyVar]
tcv'
           tvs' :: [TyVar]
tvs'       = [TyVar] -> [TyVar]
scopedSort [TyVar]
tv'
           cvs' :: [TyVar]
cvs'       = [TyVar] -> [TyVar]
scopedSort [TyVar]
cv'
           axiom :: CoAxiom Unbranched
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'

     ; FamFlavor -> CoAxiom Unbranched -> TcM FamInst
newFamInst FamFlavor
SynFamilyInst CoAxiom Unbranched
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 (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe a
isApp where

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

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

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

      -- Does it have no interesting structure to represent?
      if Bool -> Bool
not Bool
interesting then Maybe a
forall a. Maybe a
Nothing
        else -- Is the argument the parameter? Special case for mkRec1.
          if TyVar -> Maybe TyVar
forall a. a -> Maybe a
Just TyVar
argVar Maybe TyVar -> Maybe TyVar -> Bool
forall a. Eq a => a -> a -> Bool
== Type -> Maybe TyVar
getTyVar_maybe Type
beta then a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ Type -> a
mkRec1 Type
phi
            else Type -> a -> a
mkComp Type
phi (a -> a) -> Maybe a -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Type -> Maybe a
go Type
beta -- It must be a composition.


tc_mkRepTy ::  -- Gen0_ or Gen1_, for Rep or Rep1
               GenericKind_
              -- The type to generate representation for
            -> TyCon
              -- 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_ -> TyCon -> Type -> TcM Type
tc_mkRepTy GenericKind_
gk_ TyCon
tycon Type
k =
  do
    TyCon
d1      <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
d1TyConName
    TyCon
c1      <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
c1TyConName
    TyCon
s1      <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
s1TyConName
    TyCon
rec0    <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
rec0TyConName
    TyCon
rec1    <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
rec1TyConName
    TyCon
par1    <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
par1TyConName
    TyCon
u1      <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
u1TyConName
    TyCon
v1      <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
v1TyConName
    TyCon
plus    <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
sumTyConName
    TyCon
times   <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
prodTyConName
    TyCon
comp    <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
compTyConName
    TyCon
uAddr   <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
uAddrTyConName
    TyCon
uChar   <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
uCharTyConName
    TyCon
uDouble <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
uDoubleTyConName
    TyCon
uFloat  <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
uFloatTyConName
    TyCon
uInt    <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
uIntTyConName
    TyCon
uWord   <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
uWordTyConName

    let tcLookupPromDataCon :: Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupPromDataCon = (DataCon -> TyCon)
-> IOEnv (Env TcGblEnv TcLclEnv) DataCon
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
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

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

    FixityEnv
fix_env <- TcRn FixityEnv
getFixityEnv

    let mkSum' :: Type -> Type -> Type
mkSum' Type
a Type
b = TyCon -> [Type] -> Type
mkTyConApp TyCon
plus  [Type
k,Type
a,Type
b]
        mkProd :: Type -> Type -> Type
mkProd Type
a Type
b = TyCon -> [Type] -> Type
mkTyConApp TyCon
times [Type
k,Type
a,Type
b]
        mkRec0 :: Type -> Type
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 -> Type
mkRec1 Type
a   = TyCon -> [Type] -> Type
mkTyConApp TyCon
rec1  [Type
k,Type
a]
        mkPar1 :: Type
mkPar1     = TyCon -> Type
mkTyConTy  TyCon
par1
        mkD :: TyCon -> Type
mkD    TyCon
a   = TyCon -> [Type] -> Type
mkTyConApp TyCon
d1 [ Type
k, Type
metaDataTy, [DataCon] -> Type
sumP (TyCon -> [DataCon]
tyConDataCons TyCon
a) ]
        mkC :: DataCon -> Type
mkC      DataCon
a = TyCon -> [Type] -> Type
mkTyConApp TyCon
c1 [ Type
k
                                   , DataCon -> Type
metaConsTy DataCon
a
                                   , [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type
prod ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing ([Scaled Type] -> [Type])
-> (TyCon -> [Scaled Type]) -> TyCon -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> [Type] -> [Scaled Type]
dataConInstOrigArgTys DataCon
a
                                            ([Type] -> [Scaled Type])
-> (TyCon -> [Type]) -> TyCon -> [Scaled Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TyVar] -> [Type]
mkTyVarTys ([TyVar] -> [Type]) -> (TyCon -> [TyVar]) -> TyCon -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> [TyVar]
tyConTyVars (TyCon -> [Type]) -> TyCon -> [Type]
forall a b. (a -> b) -> a -> b
$ TyCon
tycon)
                                          (DataCon -> [HsSrcBang]
dataConSrcBangs    DataCon
a)
                                          (DataCon -> [HsImplBang]
dataConImplBangs   DataCon
a)
                                          (DataCon -> [FieldLabel]
dataConFieldLabels DataCon
a)]
        mkS :: Maybe FieldLabel
-> SrcUnpackedness -> SrcStrictness -> HsImplBang -> Type -> Type
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] -> Type
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 :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type
        prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type
prod [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])
                                  [ ASSERT(null fl || lengthExceeds fl j)
                                    Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type
arg Type
t HsSrcBang
sb' HsImplBang
ib' (if [FieldLabel] -> 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. [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 :: Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type
        arg :: Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type
arg Type
t (HsSrcBang SourceText
_ 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_
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_
Gen0_        -> Type -> Type
mkRec0 Type
t
                      Gen1_ 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 = 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 :: forall a.
(Type -> a) -> a -> (Type -> a) -> (Type -> a -> a) -> ArgTyAlg a
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 :: Name
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 :: Type
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 :: Type
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 :: Type
pkgName = FastString -> Type
mkStrLitTy (FastString -> Type) -> (TyCon -> FastString) -> TyCon -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unit -> 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 :: Type
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 :: DataCon -> Type
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 -> Type
ctFix DataCon
c
            | DataCon -> Bool
dataConIsInfix DataCon
c
            = case FixityEnv -> Name -> Fixity
lookupFixity FixityEnv
fix_env (DataCon -> Name
dataConName DataCon
c) of
                   Fixity SourceText
_ US
n FixityDirection
InfixL -> US -> TyCon -> Type
buildFix US
n TyCon
pLA
                   Fixity SourceText
_ US
n FixityDirection
InfixR -> US -> TyCon -> Type
buildFix US
n TyCon
pRA
                   Fixity SourceText
_ US
n FixityDirection
InfixN -> US -> TyCon -> Type
buildFix US
n TyCon
pNA
            | Bool
otherwise = TyCon -> Type
mkTyConTy TyCon
pPrefix
        buildFix :: US -> TyCon -> Type
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 -> Type
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 :: FieldLbl a -> Type
selName = FastString -> Type
mkStrLitTy (FastString -> Type)
-> (FieldLbl a -> FastString) -> FieldLbl a -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLbl a -> FastString
forall a. FieldLbl a -> FastString
flLabel

        mbSel :: Maybe (FieldLbl a) -> Type
mbSel Maybe (FieldLbl a)
Nothing  = TyCon -> [Type] -> Type
mkTyConApp TyCon
promotedNothingDataCon [Type
typeSymbolKind]
        mbSel (Just FieldLbl a
s) = TyCon -> [Type] -> Type
mkTyConApp TyCon
promotedJustDataCon
                                    [Type
typeSymbolKind, FieldLbl a -> Type
forall {a}. FieldLbl a -> Type
selName FieldLbl a
s]

        metaDataTy :: Type
metaDataTy   = TyCon -> [Type] -> Type
mkTyConApp TyCon
md [Type
dtName, Type
mdName, Type
pkgName, Type
isNT]
        metaConsTy :: DataCon -> Type
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
-> SrcUnpackedness -> SrcStrictness -> HsImplBang -> Type
metaSelTy Maybe FieldLabel
mlbl SrcUnpackedness
su SrcStrictness
ss HsImplBang
ib =
            TyCon -> [Type] -> Type
mkTyConApp TyCon
ms [Maybe FieldLabel -> Type
forall {a}. Maybe (FieldLbl a) -> 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
                                         HsImplBang
HsStrict    -> TyCon
pDStr
                                         HsUnpack{}  -> TyCon
pDUpk

    Type -> TcM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> Type
mkD TyCon
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 Type -> Type -> Bool
`eqType` Type
addrPrimTy   = TyCon -> [Type] -> Type
mkTyConApp TyCon
uAddr   [Type
k]
  | Type
ty Type -> Type -> Bool
`eqType` Type
charPrimTy   = TyCon -> [Type] -> Type
mkTyConApp TyCon
uChar   [Type
k]
  | Type
ty Type -> Type -> Bool
`eqType` Type
doublePrimTy = TyCon -> [Type] -> Type
mkTyConApp TyCon
uDouble [Type
k]
  | Type
ty Type -> Type -> Bool
`eqType` Type
floatPrimTy  = TyCon -> [Type] -> Type
mkTyConApp TyCon
uFloat  [Type
k]
  | Type
ty Type -> Type -> Bool
`eqType` Type
intPrimTy    = TyCon -> [Type] -> Type
mkTyConApp TyCon
uInt    [Type
k]
  | Type
ty 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
      -> [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 -> [DataCon] -> ([Alt], [Alt])
mkSum GenericKind_
_ US
_ [] = ([(Located (Pat GhcPs), LHsExpr GhcPs)
Alt
from_alt], [(Located (Pat GhcPs), LHsExpr GhcPs)
Alt
to_alt])
  where
    from_alt :: (Located (Pat GhcPs), LHsExpr GhcPs)
from_alt = (Located (Pat GhcPs)
LPat GhcPs
x_Pat, LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase LHsExpr GhcPs
x_Expr [])
    to_alt :: (Located (Pat GhcPs), LHsExpr GhcPs)
to_alt   = (Located (Pat GhcPs)
LPat 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 [DataCon]
datacons =
  -- switch the payload of gk_ to be datacon-centric instead of tycon-centric
 [((Located (Pat GhcPs), LHsExpr GhcPs),
  (Located (Pat GhcPs), LHsExpr GhcPs))]
-> ([(Located (Pat GhcPs), LHsExpr GhcPs)],
    [(Located (Pat GhcPs), LHsExpr GhcPs)])
forall a b. [(a, b)] -> ([a], [b])
unzip [ GenericKind_DC -> US -> US -> US -> DataCon -> (Alt, Alt)
mk1Sum (GenericKind_ -> DataCon -> GenericKind_DC
gk2gkDC GenericKind_
gk_ DataCon
d) US
us US
i ([DataCon] -> US
forall (t :: * -> *) a. Foldable t => t a -> US
length [DataCon]
datacons) 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_DC -- Generic or Generic1?
       -> US        -- Base for generating unique names
       -> Int       -- The index of this constructor
       -> Int       -- Total number of constructors
       -> DataCon   -- The data constructor
       -> (Alt,     -- Alternative for the T->Trep "from" function
           Alt)     -- Alternative for the Trep->T "to" function
mk1Sum :: GenericKind_DC -> US -> US -> US -> DataCon -> (Alt, Alt)
mk1Sum GenericKind_DC
gk_ US
us US
i US
n DataCon
datacon = ((Located (Pat GhcPs), LHsExpr GhcPs)
Alt
from_alt, (Located (Pat GhcPs), LHsExpr GhcPs)
Alt
to_alt)
  where
    gk :: GenericKind
gk = GenericKind_DC -> GenericKind
forgetArgVar GenericKind_DC
gk_

    -- Existentials already excluded
    argTys :: [Scaled Type]
argTys = DataCon -> [Scaled Type]
dataConOrigArgTys DataCon
datacon
    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]) ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled 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 :: (Located (Pat GhcPs), LHsExpr GhcPs)
from_alt     = (RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
datacon_rdr [RdrName]
datacon_vars, LHsExpr 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 :: (Located (Pat GhcPs), LHsExpr 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
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 (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP GhcPs
datacon_rdr [RdrName]
[IdP GhcPs]
datacon_vars
      Gen1_DC TyVar
argVar -> IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
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 -> LHsExpr 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 (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
var where
            converter :: Type -> LHsExpr GhcPs
converter = TyVar -> ArgTyAlg (LHsExpr GhcPs) -> Type -> LHsExpr GhcPs
forall a. TyVar -> ArgTyAlg a -> Type -> a
argTyFold TyVar
argVar (ArgTyAlg (LHsExpr GhcPs) -> Type -> LHsExpr GhcPs)
-> ArgTyAlg (LHsExpr GhcPs) -> Type -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ ArgTyAlg :: forall a.
(Type -> a) -> a -> (Type -> a) -> (Type -> a -> a) -> ArgTyAlg a
ArgTyAlg
              {ata_rec0 :: Type -> LHsExpr GhcPs
ata_rec0 = RdrName -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (RdrName -> LHsExpr GhcPs)
-> (Type -> RdrName) -> Type -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> RdrName
unboxRepRDR,
               ata_par1 :: LHsExpr GhcPs
ata_par1 = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
unPar1_RDR,
               ata_rec1 :: Type -> LHsExpr GhcPs
ata_rec1 = LHsExpr GhcPs -> Type -> LHsExpr GhcPs
forall a b. a -> b -> a
const (LHsExpr GhcPs -> Type -> LHsExpr GhcPs)
-> LHsExpr GhcPs -> Type -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
unRec1_RDR,
               ata_comp :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs
ata_comp = \Type
_ LHsExpr GhcPs
cnv -> (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
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
cnv)
                                    LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`nlHsCompose` IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
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 -> Located (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 (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name)
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 (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name)
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 -> LHsExpr 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 (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
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 (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
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 (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
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 (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
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 ((LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs)
-> LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall {id :: Pass}.
(IsPass id, IdGhcP id ~ RdrName) =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
prod (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
u1DataCon_RDR) [LHsExpr GhcPs]
appVars)
                      -- These M1s are meta-information for the constructor
  where
    appVars :: [LHsExpr GhcPs]
appVars = ((RdrName, Type) -> LHsExpr GhcPs)
-> [(RdrName, Type)] -> [LHsExpr GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (GenericKind_DC -> (RdrName, Type) -> LHsExpr GhcPs
wrapArg_E GenericKind_DC
gk_) [(RdrName, Type)]
varTys
    prod :: LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
prod LHsExpr (GhcPass id)
a LHsExpr (GhcPass id)
b = RdrName
IdP (GhcPass id)
prodDataCon_RDR IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
`nlHsApps` [LHsExpr (GhcPass id)
a,LHsExpr (GhcPass id)
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 (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
`nlHsVarApps` [RdrName
IdP GhcPs
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 -> LHsExpr 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 (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
var
                         -- This M1 is meta-information for the selector
  where converter :: Type -> LHsExpr GhcPs
converter = TyVar -> ArgTyAlg (LHsExpr GhcPs) -> Type -> LHsExpr GhcPs
forall a. TyVar -> ArgTyAlg a -> Type -> a
argTyFold TyVar
argVar (ArgTyAlg (LHsExpr GhcPs) -> Type -> LHsExpr GhcPs)
-> ArgTyAlg (LHsExpr GhcPs) -> Type -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ ArgTyAlg :: forall a.
(Type -> a) -> a -> (Type -> a) -> (Type -> a -> a) -> ArgTyAlg a
ArgTyAlg
          {ata_rec0 :: Type -> LHsExpr GhcPs
ata_rec0 = RdrName -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (RdrName -> LHsExpr GhcPs)
-> (Type -> RdrName) -> Type -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> RdrName
boxRepRDR,
           ata_par1 :: LHsExpr GhcPs
ata_par1 = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
par1DataCon_RDR,
           ata_rec1 :: Type -> LHsExpr GhcPs
ata_rec1 = LHsExpr GhcPs -> Type -> LHsExpr GhcPs
forall a b. a -> b -> a
const (LHsExpr GhcPs -> Type -> LHsExpr GhcPs)
-> LHsExpr GhcPs -> Type -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
rec1DataCon_RDR,
           ata_comp :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs
ata_comp = \Type
_ LHsExpr GhcPs
cnv -> IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
comp1DataCon_RDR LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`nlHsCompose`
                                  (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
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
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 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 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 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 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 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 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 ((Located (Pat GhcPs) -> Located (Pat GhcPs) -> Located (Pat GhcPs))
-> Located (Pat GhcPs)
-> [Located (Pat GhcPs)]
-> Located (Pat GhcPs)
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal Located (Pat GhcPs) -> Located (Pat GhcPs) -> Located (Pat GhcPs)
prod (RdrName -> LPat GhcPs
nlNullaryConPat RdrName
u1DataCon_RDR) [Located (Pat GhcPs)]
appVars)
                     -- These M1s are meta-information for the constructor
  where
    appVars :: [Located (Pat GhcPs)]
appVars = (RdrName -> Type -> Located (Pat GhcPs))
-> [(RdrName, Type)] -> [Located (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 :: Located (Pat GhcPs) -> Located (Pat GhcPs) -> LPat GhcPs
prod Located (Pat GhcPs)
a Located (Pat GhcPs)
b = LPat GhcPs -> LPat GhcPs
forall (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name)
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` [Located (Pat GhcPs)
LPat GhcPs
a,Located (Pat GhcPs)
LPat 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 (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name)
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 (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name)
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 (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
x_RDR

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

mkM1_E :: LHsExpr GhcPs -> LHsExpr GhcPs
mkM1_E :: LHsExpr GhcPs -> LHsExpr GhcPs
mkM1_E LHsExpr GhcPs
e = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
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 (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name)
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 = RdrName
IdP GhcPs
compose_RDR IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
`nlHsApps` [LHsExpr GhcPs
x, LHsExpr GhcPs
y]

-- | Variant of foldr for producing balanced lists
foldBal :: (a -> a -> a) -> a -> [a] -> a
foldBal :: forall a. (a -> a -> a) -> a -> [a] -> a
foldBal a -> a -> a
_  a
x []  = a
x
foldBal a -> a -> a
_  a
_ [a
y] = a
y
foldBal a -> a -> a
op a
x [a]
l   = let ([a]
a,[a]
b) = US -> [a] -> ([a], [a])
forall a. US -> [a] -> ([a], [a])
splitAt ([a] -> US
forall (t :: * -> *) a. Foldable t => t a -> US
length [a]
l US -> US -> US
forall a. Integral a => a -> a -> a
`div` US
2) [a]
l
                   in (a -> a -> a) -> a -> [a] -> a
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal a -> a -> a
op a
x [a]
a a -> a -> a
`op` (a -> a -> a) -> a -> [a] -> a
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal a -> a -> a
op a
x [a]
b

{-
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). That is, it derives the ellipsis in the following:

    instance Generic Foo where
      type Rep Foo = ...

However, tc_mkRepTy only has knowledge of the *TyCon* of the type for which
a Generic(1) instance is being derived, not the fully instantiated type. As a
result, tc_mkRepTy builds the most generalized Rep(1) instance possible using
the type variables it learns from the TyCon (i.e., it uses tyConTyVars). This
can cause problems when the instance has instantiated type variables
(see #11732). As an example:

    data T a = MkT a
    deriving instance Generic (T Int)
    ==>
    instance Generic (T Int) where
      type Rep (T Int) = (... (Rec0 a)) -- wrong!

-XStandaloneDeriving is one way for the type variables to become instantiated.
Another way is when Generic1 is being derived for a datatype with a visible
kind binder, e.g.,

   data P k (a :: k) = MkP k deriving Generic1
   ==>
   instance Generic1 (P *) where
     type Rep1 (P *) = (... (Rec0 k)) -- wrong!

See Note [Unify kinds in deriving] in GHC.Tc.Deriv.

In any such scenario, we must prevent a discrepancy between the LHS and RHS of
a Rep(1) instance. To do so, we create a type variable substitution that maps
the tyConTyVars of the TyCon to their counterparts in the fully instantiated
type. (For example, using T above as example, you'd map a :-> Int.) We then
apply the substitution to the RHS before generating the instance.

A wrinkle in all of this: when forming the type variable substitution for
Generic1 instances, we map the last type variable of the tycon to Any. Why?
It's because of wily data types like this one (#15012):

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

If we ignore a, then we'll produce the following Rep1 instance:

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

Oh no! Now we have `a` on the RHS, but it's completely unbound. Instead, we
ensure that `a` is mapped 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.
-}