{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1999
-}


{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

module GHC.Tc.Instance.Typeable(mkTypeableBinds, tyConIsTypeable) where

import GHC.Prelude
import GHC.Platform

import GHC.Types.Basic ( Boxity(..), neverInlinePragma )
import GHC.Types.SourceText ( SourceText(..) )
import GHC.Iface.Env( newGlobalBinder )
import GHC.Core.TyCo.Rep( Type(..), TyLit(..) )
import GHC.Tc.Utils.Env
import GHC.Tc.Types.Evidence ( mkWpTyApps )
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcType
import GHC.Types.TyThing ( lookupId )
import GHC.Builtin.Names
import GHC.Builtin.Types.Prim ( primTyCons )
import GHC.Builtin.Types
                  ( tupleTyCon, sumTyCon, runtimeRepTyCon
                  , levityTyCon, vecCountTyCon, vecElemTyCon
                  , nilDataCon, consDataCon )
import GHC.Types.Name
import GHC.Types.Id
import GHC.Core.Type
import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Unit.Module
import GHC.Hs
import GHC.Driver.Session
import GHC.Data.Bag
import GHC.Types.Var ( VarBndr(..) )
import GHC.Core.Map.Type
import GHC.Settings.Constants
import GHC.Utils.Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints)
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString ( FastString, mkFastString, fsLit )

import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Class (lift)
import Data.Maybe ( isJust )

{- Note [Grand plan for Typeable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The overall plan is this:

1. Generate a binding for each module p:M
   (done in GHC.Tc.Instance.Typeable by mkModIdBindings)
       M.$trModule :: GHC.Unit.Module
       M.$trModule = Module "p" "M"
   ("tr" is short for "type representation"; see GHC.Types)

   We might want to add the filename too.
   This can be used for the lightweight stack-tracing stuff too

   Record the Name M.$trModule in the tcg_tr_module field of TcGblEnv

2. Generate a binding for every data type declaration T in module M,
       M.$tcT :: GHC.Types.TyCon
       M.$tcT = TyCon ...fingerprint info...
                      $trModule
                      "T"
                      0#
                      kind_rep

   Here 0# is the number of arguments expected by the tycon to fully determine
   its kind. kind_rep is a value of type GHC.Types.KindRep, which gives a
   recipe for computing the kind of an instantiation of the tycon (see
   Note [Representing TyCon kinds: KindRep] later in this file for details).

   We define (in GHC.Core.TyCon)

        type TyConRepName = Name

   to use for these M.$tcT "tycon rep names". Note that these must be
   treated as "never exported" names by Backpack (see
   Note [Handling never-exported TyThings under Backpack]). Consequently
   they get slightly special treatment in GHC.Iface.Rename.rnIfaceDecl.

3. Record the TyConRepName in T's TyCon, including for promoted
   data and type constructors, and kinds like * and #.

   The TyConRepName is not an "implicit Id".  It's more like a record
   selector: the TyCon knows its name but you have to go to the
   interface file to find its type, value, etc

4. Solve Typeable constraints.  This is done by a custom Typeable solver,
   currently in GHC.Tc.Solver.Interact, that use M.$tcT so solve (Typeable T).

There are many wrinkles:

* The timing of when we produce this bindings is rather important: they must be
  defined after the rest of the module has been typechecked since we need to be
  able to lookup Module and TyCon in the type environment and we may be
  currently compiling GHC.Types (where they are defined).

* GHC.Prim doesn't have any associated object code, so we need to put the
  representations for types defined in this module elsewhere. We chose this
  place to be GHC.Types. GHC.Tc.Instance.Typeable.mkPrimTypeableBinds is responsible for
  injecting the bindings for the GHC.Prim representions when compiling
  GHC.Types.

* TyCon.tyConRepModOcc is responsible for determining where to find
  the representation binding for a given type. This is where we handle
  the special case for GHC.Prim.

* To save space and reduce dependencies, we need use quite low-level
  representations for TyCon and Module.  See GHC.Types
  Note [Runtime representation of modules and tycons]

* The KindReps can unfortunately get quite large. Moreover, the simplifier will
  float out various pieces of them, resulting in numerous top-level bindings.
  Consequently we mark the KindRep bindings as noinline, ensuring that the
  float-outs don't make it into the interface file. This is important since
  there is generally little benefit to inlining KindReps and they would
  otherwise strongly affect compiler performance.

* In general there are lots of things of kind *, * -> *, and * -> * -> *. To
  reduce the number of bindings we need to produce, we generate their KindReps
  once in GHC.Types. These are referred to as "built-in" KindReps below.

* Even though KindReps aren't inlined, this scheme still has more of an effect on
  compilation time than I'd like. This is especially true in the case of
  families of type constructors (e.g. tuples and unboxed sums). The problem is
  particularly bad in the case of sums, since each arity-N tycon brings with it
  N promoted datacons, each with a KindRep whose size also scales with N.
  Consequently we currently simply don't allow sums to be Typeable.

  In general we might consider moving some or all of this generation logic back
  to the solver since the performance hit we take in doing this at
  type-definition time is non-trivial and Typeable isn't very widely used. This
  is discussed in #13261.

-}

-- | Generate the Typeable bindings for a module. This is the only
-- entry-point of this module and is invoked by the typechecker driver in
-- 'tcRnSrcDecls'.
--
-- See Note [Grand plan for Typeable] in "GHC.Tc.Instance.Typeable".
mkTypeableBinds :: TcM TcGblEnv
mkTypeableBinds :: TcM TcGblEnv
mkTypeableBinds
  = do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NoTypeableBinds DynFlags
dflags then TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv else do
       { -- Create a binding for $trModule.
         -- Do this before processing any data type declarations,
         -- which need tcg_tr_module to be initialised
       ; TcGblEnv
tcg_env <- TcM TcGblEnv
mkModIdBindings
         -- Now we can generate the TyCon representations...
         -- First we handle the primitive TyCons if we are compiling GHC.Types
       ; (TcGblEnv
tcg_env, [TypeRepTodo]
prim_todos) <- TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, [TypeRepTodo])
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, [TypeRepTodo])
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env TcRnIf TcGblEnv TcLclEnv (TcGblEnv, [TypeRepTodo])
mkPrimTypeableTodos

         -- Then we produce bindings for the user-defined types in this module.
       ; TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
    do { Module
mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
       ; let tycons :: [TyCon]
tycons = (TyCon -> Bool) -> [TyCon] -> [TyCon]
forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
needs_typeable_binds (TcGblEnv -> [TyCon]
tcg_tcs TcGblEnv
tcg_env)
             mod_id :: Var
mod_id = case TcGblEnv -> Maybe Var
tcg_tr_module TcGblEnv
tcg_env of  -- Should be set by now
                        Just Var
mod_id -> Var
mod_id
                        Maybe Var
Nothing     -> String -> SDoc -> Var
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcMkTypeableBinds" ([TyCon] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyCon]
tycons)
       ; String -> SDoc -> TcRn ()
traceTc String
"mkTypeableBinds" ([TyCon] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyCon]
tycons)
       ; TypeRepTodo
this_mod_todos <- Module -> Var -> [TyCon] -> TcM TypeRepTodo
todoForTyCons Module
mod Var
mod_id [TyCon]
tycons
       ; [TypeRepTodo] -> TcM TcGblEnv
mkTypeRepTodoBinds (TypeRepTodo
this_mod_todos TypeRepTodo -> [TypeRepTodo] -> [TypeRepTodo]
forall a. a -> [a] -> [a]
: [TypeRepTodo]
prim_todos)
       } } }
  where
    needs_typeable_binds :: TyCon -> Bool
needs_typeable_binds TyCon
tc
      | TyCon
tc TyCon -> [TyCon] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TyCon]
ghcTypesTypeableTyCons
      = Bool
False
      | Bool
otherwise =
          TyCon -> Bool
isAlgTyCon TyCon
tc
       Bool -> Bool -> Bool
|| TyCon -> Bool
isDataFamilyTyCon TyCon
tc
       Bool -> Bool -> Bool
|| TyCon -> Bool
isClassTyCon TyCon
tc


{- *********************************************************************
*                                                                      *
            Building top-level binding for $trModule
*                                                                      *
********************************************************************* -}

mkModIdBindings :: TcM TcGblEnv
mkModIdBindings :: TcM TcGblEnv
mkModIdBindings
  = do { Module
mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
       ; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
       ; Name
mod_nm        <- Module -> OccName -> SrcSpan -> TcRnIf TcGblEnv TcLclEnv Name
forall a b. Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder Module
mod (String -> OccName
mkVarOcc String
"$trModule") SrcSpan
loc
       ; TyCon
trModuleTyCon <- Name -> TcM TyCon
tcLookupTyCon Name
trModuleTyConName
       ; let mod_id :: Var
mod_id = Name -> Type -> Var
mkExportedVanillaId Name
mod_nm (TyCon -> [Type] -> Type
mkTyConApp TyCon
trModuleTyCon [])
       ; GenLocated
  SrcSpanAnnA
  (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
mod_bind      <- IdP (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsBind (GhcPass 'Typechecked)
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind IdP (GhcPass 'Typechecked)
Var
mod_id (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
 -> GenLocated
      SrcSpanAnnA
      (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated
        SrcSpanAnnA
        (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Module -> TcM (LHsExpr (GhcPass 'Typechecked))
mkModIdRHS Module
mod

       ; TcGblEnv
tcg_env <- [Var] -> TcM TcGblEnv -> TcM TcGblEnv
forall a. [Var] -> TcM a -> TcM a
tcExtendGlobalValEnv [Var
mod_id] TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env { tcg_tr_module :: Maybe Var
tcg_tr_module = Var -> Maybe Var
forall a. a -> Maybe a
Just Var
mod_id }
                 TcGblEnv -> [LHsBinds (GhcPass 'Typechecked)] -> TcGblEnv
`addTypecheckedBinds` [GenLocated
  SrcSpanAnnA
  (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
-> Bag
     (GenLocated
        SrcSpanAnnA
        (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))
forall a. a -> Bag a
unitBag GenLocated
  SrcSpanAnnA
  (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
mod_bind]) }

mkModIdRHS :: Module -> TcM (LHsExpr GhcTc)
mkModIdRHS :: Module -> TcM (LHsExpr (GhcPass 'Typechecked))
mkModIdRHS Module
mod
  = do { DataCon
trModuleDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
trModuleDataConName
       ; FastString
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
trNameLit <- TcM (FastString -> LHsExpr (GhcPass 'Typechecked))
IOEnv
  (Env TcGblEnv TcLclEnv)
  (FastString
   -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
mkTrNameLit
       ; GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
trModuleDataCon
                  LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` FastString
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
trNameLit (Unit -> FastString
forall u. IsUnitId u => u -> FastString
unitFS (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod))
                  LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` FastString
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
trNameLit (ModuleName -> FastString
moduleNameFS (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod))
       }

{- *********************************************************************
*                                                                      *
                Building type-representation bindings
*                                                                      *
********************************************************************* -}

-- | Information we need about a 'TyCon' to generate its representation. We
-- carry the 'Id' in order to share it between the generation of the @TyCon@ and
-- @KindRep@ bindings.
data TypeableTyCon
    = TypeableTyCon
      { TypeableTyCon -> TyCon
tycon        :: !TyCon
      , TypeableTyCon -> Var
tycon_rep_id :: !Id
      }

-- | A group of 'TyCon's in need of type-rep bindings.
data TypeRepTodo
    = TypeRepTodo
      { TypeRepTodo -> LHsExpr (GhcPass 'Typechecked)
mod_rep_expr    :: LHsExpr GhcTc    -- ^ Module's typerep binding
      , TypeRepTodo -> Fingerprint
pkg_fingerprint :: !Fingerprint     -- ^ Package name fingerprint
      , TypeRepTodo -> Fingerprint
mod_fingerprint :: !Fingerprint     -- ^ Module name fingerprint
      , TypeRepTodo -> [TypeableTyCon]
todo_tycons     :: [TypeableTyCon]
        -- ^ The 'TyCon's in need of bindings kinds
      }
    | ExportedKindRepsTodo [(Kind, Id)]
      -- ^ Build exported 'KindRep' bindings for the given set of kinds.

todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo
todoForTyCons :: Module -> Var -> [TyCon] -> TcM TypeRepTodo
todoForTyCons Module
mod Var
mod_id [TyCon]
tycons = do
    Type
trTyConTy <- TyCon -> Type
mkTyConTy (TyCon -> Type) -> TcM TyCon -> IOEnv (Env TcGblEnv TcLclEnv) Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TcM TyCon
tcLookupTyCon Name
trTyConTyConName
    let mk_rep_id :: TyConRepName -> Id
        mk_rep_id :: Name -> Var
mk_rep_id Name
rep_name = Name -> Type -> Var
mkExportedVanillaId Name
rep_name Type
trTyConTy

    let typeable_tycons :: [TypeableTyCon]
        typeable_tycons :: [TypeableTyCon]
typeable_tycons =
            [ TypeableTyCon { tycon :: TyCon
tycon = TyCon
tc''
                            , tycon_rep_id :: Var
tycon_rep_id = Name -> Var
mk_rep_id Name
rep_name
                            }
            | TyCon
tc     <- [TyCon]
tycons
            , TyCon
tc'    <- TyCon
tc TyCon -> [TyCon] -> [TyCon]
forall a. a -> [a] -> [a]
: TyCon -> [TyCon]
tyConATs TyCon
tc
              -- We need type representations for any associated types
            , let promoted :: [TyCon]
promoted = (DataCon -> TyCon) -> [DataCon] -> [TyCon]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> TyCon
promoteDataCon (TyCon -> [DataCon]
tyConDataCons TyCon
tc')
            , TyCon
tc''   <- TyCon
tc' TyCon -> [TyCon] -> [TyCon]
forall a. a -> [a] -> [a]
: [TyCon]
promoted
              -- Don't make bindings for data-family instance tycons.
              -- Do, however, make them for their promoted datacon (see #13915).
            , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ TyCon -> Bool
isFamInstTyCon TyCon
tc''
            , Just Name
rep_name <- Maybe Name -> [Maybe Name]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Name -> [Maybe Name]) -> Maybe Name -> [Maybe Name]
forall a b. (a -> b) -> a -> b
$ TyCon -> Maybe Name
tyConRepName_maybe TyCon
tc''
            , TyCon -> Bool
tyConIsTypeable TyCon
tc''
            ]
    TypeRepTodo -> TcM TypeRepTodo
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TypeRepTodo { mod_rep_expr :: LHsExpr (GhcPass 'Typechecked)
mod_rep_expr    = IdP (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Typechecked)
Var
mod_id
                       , pkg_fingerprint :: Fingerprint
pkg_fingerprint = Fingerprint
pkg_fpr
                       , mod_fingerprint :: Fingerprint
mod_fingerprint = Fingerprint
mod_fpr
                       , todo_tycons :: [TypeableTyCon]
todo_tycons     = [TypeableTyCon]
typeable_tycons
                       }
  where
    mod_fpr :: Fingerprint
mod_fpr = String -> Fingerprint
fingerprintString (String -> Fingerprint) -> String -> Fingerprint
forall a b. (a -> b) -> a -> b
$ ModuleName -> String
moduleNameString (ModuleName -> String) -> ModuleName -> String
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod
    pkg_fpr :: Fingerprint
pkg_fpr = String -> Fingerprint
fingerprintString (String -> Fingerprint) -> String -> Fingerprint
forall a b. (a -> b) -> a -> b
$ Unit -> String
forall u. IsUnitId u => u -> String
unitString (Unit -> String) -> Unit -> String
forall a b. (a -> b) -> a -> b
$ Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod

todoForExportedKindReps :: [(Kind, Name)] -> TcM TypeRepTodo
todoForExportedKindReps :: [(Type, Name)] -> TcM TypeRepTodo
todoForExportedKindReps [(Type, Name)]
kinds = do
    Type
trKindRepTy <- TyCon -> Type
mkTyConTy (TyCon -> Type) -> TcM TyCon -> IOEnv (Env TcGblEnv TcLclEnv) Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TcM TyCon
tcLookupTyCon Name
kindRepTyConName
    let mkId :: (Type, Name) -> (Type, Var)
mkId (Type
k, Name
name) = (Type
k, Name -> Type -> Var
mkExportedVanillaId Name
name Type
trKindRepTy)
    TypeRepTodo -> TcM TypeRepTodo
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeRepTodo -> TcM TypeRepTodo) -> TypeRepTodo -> TcM TypeRepTodo
forall a b. (a -> b) -> a -> b
$ [(Type, Var)] -> TypeRepTodo
ExportedKindRepsTodo ([(Type, Var)] -> TypeRepTodo) -> [(Type, Var)] -> TypeRepTodo
forall a b. (a -> b) -> a -> b
$ ((Type, Name) -> (Type, Var)) -> [(Type, Name)] -> [(Type, Var)]
forall a b. (a -> b) -> [a] -> [b]
map (Type, Name) -> (Type, Var)
mkId [(Type, Name)]
kinds

-- | Generate TyCon bindings for a set of type constructors
mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv
mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv
mkTypeRepTodoBinds [] = TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
mkTypeRepTodoBinds [TypeRepTodo]
todos
  = do { TypeableStuff
stuff <- TcM TypeableStuff
collect_stuff

         -- First extend the type environment with all of the bindings
         -- which we are going to produce since we may need to refer to them
         -- while generating kind representations (namely, when we want to
         -- represent a TyConApp in a kind, we must be able to look up the
         -- TyCon associated with the applied type constructor).
       ; let produced_bndrs :: [Id]
             produced_bndrs :: [Var]
produced_bndrs = [ Var
tycon_rep_id
                              | todo :: TypeRepTodo
todo@(TypeRepTodo{}) <- [TypeRepTodo]
todos
                              , TypeableTyCon {Var
TyCon
tycon :: TypeableTyCon -> TyCon
tycon_rep_id :: TypeableTyCon -> Var
tycon_rep_id :: Var
tycon :: TyCon
..} <- TypeRepTodo -> [TypeableTyCon]
todo_tycons TypeRepTodo
todo
                              ] [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++
                              [ Var
rep_id
                              | ExportedKindRepsTodo [(Type, Var)]
kinds <- [TypeRepTodo]
todos
                              , (Type
_, Var
rep_id) <- [(Type, Var)]
kinds
                              ]
       ; TcGblEnv
gbl_env <- [Var] -> TcM TcGblEnv -> TcM TcGblEnv
forall a. [Var] -> TcM a -> TcM a
tcExtendGlobalValEnv [Var]
produced_bndrs TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv

       ; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds GhcTc]
             mk_binds :: TypeRepTodo -> KindRepM [LHsBinds (GhcPass 'Typechecked)]
mk_binds todo :: TypeRepTodo
todo@(TypeRepTodo {}) =
                 (TypeableTyCon
 -> KindRepM
      (Bag
         (GenLocated
            SrcSpanAnnA
            (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))))
-> [TypeableTyCon]
-> KindRepM
     [Bag
        (GenLocated
           SrcSpanAnnA
           (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TypeableStuff
-> TypeRepTodo
-> TypeableTyCon
-> KindRepM (LHsBinds (GhcPass 'Typechecked))
mkTyConRepBinds TypeableStuff
stuff TypeRepTodo
todo) (TypeRepTodo -> [TypeableTyCon]
todo_tycons TypeRepTodo
todo)
             mk_binds (ExportedKindRepsTodo [(Type, Var)]
kinds) =
                 TypeableStuff -> [(Type, Var)] -> KindRepM ()
mkExportedKindReps TypeableStuff
stuff [(Type, Var)]
kinds KindRepM ()
-> KindRepM
     [Bag
        (GenLocated
           SrcSpanAnnA
           (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))]
-> KindRepM
     [Bag
        (GenLocated
           SrcSpanAnnA
           (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))]
forall a b. KindRepM a -> KindRepM b -> KindRepM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Bag
   (GenLocated
      SrcSpanAnnA
      (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))]
-> KindRepM
     [Bag
        (GenLocated
           SrcSpanAnnA
           (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))]
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return []

       ; (TcGblEnv
gbl_env, [[Bag
    (GenLocated
       SrcSpanAnnA
       (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))]]
binds) <- TcGblEnv
-> TcRnIf
     TcGblEnv
     TcLclEnv
     (TcGblEnv,
      [[Bag
          (GenLocated
             SrcSpanAnnA
             (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))]])
-> TcRnIf
     TcGblEnv
     TcLclEnv
     (TcGblEnv,
      [[Bag
          (GenLocated
             SrcSpanAnnA
             (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))]])
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
gbl_env
                             (TcRnIf
   TcGblEnv
   TcLclEnv
   (TcGblEnv,
    [[Bag
        (GenLocated
           SrcSpanAnnA
           (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))]])
 -> TcRnIf
      TcGblEnv
      TcLclEnv
      (TcGblEnv,
       [[Bag
           (GenLocated
              SrcSpanAnnA
              (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))]]))
-> TcRnIf
     TcGblEnv
     TcLclEnv
     (TcGblEnv,
      [[Bag
          (GenLocated
             SrcSpanAnnA
             (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))]])
-> TcRnIf
     TcGblEnv
     TcLclEnv
     (TcGblEnv,
      [[Bag
          (GenLocated
             SrcSpanAnnA
             (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))]])
forall a b. (a -> b) -> a -> b
$ KindRepM
  [[Bag
      (GenLocated
         SrcSpanAnnA
         (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))]]
-> TcRnIf
     TcGblEnv
     TcLclEnv
     (TcGblEnv,
      [[Bag
          (GenLocated
             SrcSpanAnnA
             (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))]])
forall a. KindRepM a -> TcRn (TcGblEnv, a)
runKindRepM ((TypeRepTodo
 -> KindRepM
      [Bag
         (GenLocated
            SrcSpanAnnA
            (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))])
-> [TypeRepTodo]
-> KindRepM
     [[Bag
         (GenLocated
            SrcSpanAnnA
            (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TypeRepTodo -> KindRepM [LHsBinds (GhcPass 'Typechecked)]
TypeRepTodo
-> KindRepM
     [Bag
        (GenLocated
           SrcSpanAnnA
           (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))]
mk_binds [TypeRepTodo]
todos)
       ; TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> TcM TcGblEnv) -> TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ TcGblEnv
gbl_env TcGblEnv -> [LHsBinds (GhcPass 'Typechecked)] -> TcGblEnv
`addTypecheckedBinds` [[Bag
    (GenLocated
       SrcSpanAnnA
       (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))]]
-> [Bag
      (GenLocated
         SrcSpanAnnA
         (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Bag
    (GenLocated
       SrcSpanAnnA
       (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))]]
binds }

-- | Generate bindings for the type representation of a wired-in 'TyCon's
-- defined by the virtual "GHC.Prim" module. This is where we inject the
-- representation bindings for these primitive types into "GHC.Types"
--
-- See Note [Grand plan for Typeable] in this module.
mkPrimTypeableTodos :: TcM (TcGblEnv, [TypeRepTodo])
mkPrimTypeableTodos :: TcRnIf TcGblEnv TcLclEnv (TcGblEnv, [TypeRepTodo])
mkPrimTypeableTodos
  = do { Module
mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
       ; if Module
mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
gHC_TYPES
           then do { -- Build Module binding for GHC.Prim
                     TyCon
trModuleTyCon <- Name -> TcM TyCon
tcLookupTyCon Name
trModuleTyConName
                   ; let ghc_prim_module_id :: Var
ghc_prim_module_id =
                             Name -> Type -> Var
mkExportedVanillaId Name
trGhcPrimModuleName
                                                 (TyCon -> Type
mkTyConTy TyCon
trModuleTyCon)

                   ; GenLocated
  SrcSpanAnnA
  (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
ghc_prim_module_bind <- IdP (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsBind (GhcPass 'Typechecked)
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind IdP (GhcPass 'Typechecked)
Var
ghc_prim_module_id
                                             (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
 -> GenLocated
      SrcSpanAnnA
      (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated
        SrcSpanAnnA
        (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Module -> TcM (LHsExpr (GhcPass 'Typechecked))
mkModIdRHS Module
gHC_PRIM

                     -- Extend our environment with above
                   ; TcGblEnv
gbl_env <- [Var] -> TcM TcGblEnv -> TcM TcGblEnv
forall a. [Var] -> TcM a -> TcM a
tcExtendGlobalValEnv [Var
ghc_prim_module_id]
                                                     TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
                   ; let gbl_env' :: TcGblEnv
gbl_env' = TcGblEnv
gbl_env TcGblEnv -> [LHsBinds (GhcPass 'Typechecked)] -> TcGblEnv
`addTypecheckedBinds`
                                    [GenLocated
  SrcSpanAnnA
  (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
-> Bag
     (GenLocated
        SrcSpanAnnA
        (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))
forall a. a -> Bag a
unitBag GenLocated
  SrcSpanAnnA
  (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
ghc_prim_module_bind]

                     -- Build TypeRepTodos for built-in KindReps
                   ; TypeRepTodo
todo1 <- [(Type, Name)] -> TcM TypeRepTodo
todoForExportedKindReps [(Type, Name)]
builtInKindReps
                     -- Build TypeRepTodos for types in GHC.Prim
                   ; TypeRepTodo
todo2 <- Module -> Var -> [TyCon] -> TcM TypeRepTodo
todoForTyCons Module
gHC_PRIM Var
ghc_prim_module_id
                                            [TyCon]
ghcPrimTypeableTyCons
                   ; TcGblEnv
tcg_env <- TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
                   ; let mod_id :: Var
mod_id = case TcGblEnv -> Maybe Var
tcg_tr_module TcGblEnv
tcg_env of  -- Should be set by now
                                   Just Var
mod_id -> Var
mod_id
                                   Maybe Var
Nothing     -> String -> SDoc -> Var
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcMkTypeableBinds" SDoc
empty

                   ; TypeRepTodo
todo3 <- Module -> Var -> [TyCon] -> TcM TypeRepTodo
todoForTyCons Module
gHC_TYPES Var
mod_id [TyCon]
ghcTypesTypeableTyCons

                   ; (TcGblEnv, [TypeRepTodo])
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, [TypeRepTodo])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ( TcGblEnv
gbl_env' , [TypeRepTodo
todo1, TypeRepTodo
todo2, TypeRepTodo
todo3])
                   }
           else do TcGblEnv
gbl_env <- TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
                   (TcGblEnv, [TypeRepTodo])
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, [TypeRepTodo])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
gbl_env, [])
       }

-- | This is the list of primitive 'TyCon's for which we must generate bindings
-- in "GHC.Types". This should include all types defined in "GHC.Prim".
--
-- The majority of the types we need here are contained in 'primTyCons'.
-- However, not all of them: in particular unboxed tuples are absent since we
-- don't want to include them in the original name cache. See
-- Note [Built-in syntax and the OrigNameCache] in "GHC.Iface.Env" for more.
ghcPrimTypeableTyCons :: [TyCon]
ghcPrimTypeableTyCons :: [TyCon]
ghcPrimTypeableTyCons = [[TyCon]] -> [TyCon]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ (Int -> TyCon) -> [Int] -> [TyCon]
forall a b. (a -> b) -> [a] -> [b]
map (Boxity -> Int -> TyCon
tupleTyCon Boxity
Unboxed) [Int
0..Int
mAX_TUPLE_SIZE]
    , (Int -> TyCon) -> [Int] -> [TyCon]
forall a b. (a -> b) -> [a] -> [b]
map Int -> TyCon
sumTyCon [Int
2..Int
mAX_SUM_SIZE]
    , [TyCon]
primTyCons
    ]

-- | These are types which are defined in GHC.Types but are needed in order to
-- typecheck the other generated bindings, therefore to avoid ordering issues we
-- generate them up-front along with the bindings from GHC.Prim.
ghcTypesTypeableTyCons :: [TyCon]
ghcTypesTypeableTyCons :: [TyCon]
ghcTypesTypeableTyCons = [ TyCon
runtimeRepTyCon, TyCon
levityTyCon
                         , TyCon
vecCountTyCon, TyCon
vecElemTyCon ]

data TypeableStuff
    = Stuff { TypeableStuff -> Platform
platform       :: Platform        -- ^ Target platform
            , TypeableStuff -> DataCon
trTyConDataCon :: DataCon         -- ^ of @TyCon@
            , TypeableStuff -> FastString -> LHsExpr (GhcPass 'Typechecked)
trNameLit      :: FastString -> LHsExpr GhcTc
                                                -- ^ To construct @TrName@s
              -- The various TyCon and DataCons of KindRep
            , TypeableStuff -> TyCon
kindRepTyCon           :: TyCon
            , TypeableStuff -> DataCon
kindRepTyConAppDataCon :: DataCon
            , TypeableStuff -> DataCon
kindRepVarDataCon      :: DataCon
            , TypeableStuff -> DataCon
kindRepAppDataCon      :: DataCon
            , TypeableStuff -> DataCon
kindRepFunDataCon      :: DataCon
            , TypeableStuff -> DataCon
kindRepTYPEDataCon     :: DataCon
            , TypeableStuff -> DataCon
kindRepTypeLitSDataCon :: DataCon
            , TypeableStuff -> DataCon
typeLitSymbolDataCon   :: DataCon
            , TypeableStuff -> DataCon
typeLitCharDataCon     :: DataCon
            , TypeableStuff -> DataCon
typeLitNatDataCon      :: DataCon
            }

-- | Collect various tidbits which we'll need to generate TyCon representations.
collect_stuff :: TcM TypeableStuff
collect_stuff :: TcM TypeableStuff
collect_stuff = do
    Platform
platform               <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform)
-> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
-> IOEnv (Env TcGblEnv TcLclEnv) Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    DataCon
trTyConDataCon         <- Name -> TcM DataCon
tcLookupDataCon Name
trTyConDataConName
    TyCon
kindRepTyCon           <- Name -> TcM TyCon
tcLookupTyCon   Name
kindRepTyConName
    DataCon
kindRepTyConAppDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepTyConAppDataConName
    DataCon
kindRepVarDataCon      <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepVarDataConName
    DataCon
kindRepAppDataCon      <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepAppDataConName
    DataCon
kindRepFunDataCon      <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepFunDataConName
    DataCon
kindRepTYPEDataCon     <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepTYPEDataConName
    DataCon
kindRepTypeLitSDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepTypeLitSDataConName
    DataCon
typeLitSymbolDataCon   <- Name -> TcM DataCon
tcLookupDataCon Name
typeLitSymbolDataConName
    DataCon
typeLitNatDataCon      <- Name -> TcM DataCon
tcLookupDataCon Name
typeLitNatDataConName
    DataCon
typeLitCharDataCon     <- Name -> TcM DataCon
tcLookupDataCon Name
typeLitCharDataConName
    FastString
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
trNameLit              <- TcM (FastString -> LHsExpr (GhcPass 'Typechecked))
IOEnv
  (Env TcGblEnv TcLclEnv)
  (FastString
   -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
mkTrNameLit
    TypeableStuff -> TcM TypeableStuff
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Stuff {TyCon
Platform
DataCon
FastString -> LHsExpr (GhcPass 'Typechecked)
FastString
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
platform :: Platform
trTyConDataCon :: DataCon
trNameLit :: FastString -> LHsExpr (GhcPass 'Typechecked)
kindRepTyCon :: TyCon
kindRepTyConAppDataCon :: DataCon
kindRepVarDataCon :: DataCon
kindRepAppDataCon :: DataCon
kindRepFunDataCon :: DataCon
kindRepTYPEDataCon :: DataCon
kindRepTypeLitSDataCon :: DataCon
typeLitSymbolDataCon :: DataCon
typeLitCharDataCon :: DataCon
typeLitNatDataCon :: DataCon
platform :: Platform
trTyConDataCon :: DataCon
kindRepTyCon :: TyCon
kindRepTyConAppDataCon :: DataCon
kindRepVarDataCon :: DataCon
kindRepAppDataCon :: DataCon
kindRepFunDataCon :: DataCon
kindRepTYPEDataCon :: DataCon
kindRepTypeLitSDataCon :: DataCon
typeLitSymbolDataCon :: DataCon
typeLitNatDataCon :: DataCon
typeLitCharDataCon :: DataCon
trNameLit :: FastString
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
..}

-- | Lookup the necessary pieces to construct the @trNameLit@. We do this so we
-- can save the work of repeating lookups when constructing many TyCon
-- representations.
mkTrNameLit :: TcM (FastString -> LHsExpr GhcTc)
mkTrNameLit :: TcM (FastString -> LHsExpr (GhcPass 'Typechecked))
mkTrNameLit = do
    DataCon
trNameSDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
trNameSDataConName
    let trNameLit :: FastString -> LHsExpr GhcTc
        trNameLit :: FastString -> LHsExpr (GhcPass 'Typechecked)
trNameLit FastString
fs = LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked))
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
trNameSDataCon
                       LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (FastString -> HsLit (GhcPass 'Typechecked)
forall (p :: Pass). FastString -> HsLit (GhcPass p)
mkHsStringPrimLit FastString
fs)
    (FastString
 -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (FastString
      -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return FastString -> LHsExpr (GhcPass 'Typechecked)
FastString
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
trNameLit

-- | Make Typeable bindings for the given 'TyCon'.
mkTyConRepBinds :: TypeableStuff -> TypeRepTodo
                -> TypeableTyCon -> KindRepM (LHsBinds GhcTc)
mkTyConRepBinds :: TypeableStuff
-> TypeRepTodo
-> TypeableTyCon
-> KindRepM (LHsBinds (GhcPass 'Typechecked))
mkTyConRepBinds TypeableStuff
stuff TypeRepTodo
todo (TypeableTyCon {Var
TyCon
tycon :: TypeableTyCon -> TyCon
tycon_rep_id :: TypeableTyCon -> Var
tycon :: TyCon
tycon_rep_id :: Var
..})
  = do -- Make a KindRep
       let ([TyCoVarBinder]
bndrs, Type
kind) = Type -> ([TyCoVarBinder], Type)
splitForAllTyCoVarBinders (TyCon -> Type
tyConKind TyCon
tycon)
       TcRn () -> KindRepM ()
forall a. TcRn a -> KindRepM a
liftTc (TcRn () -> KindRepM ()) -> TcRn () -> KindRepM ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc -> TcRn ()
traceTc String
"mkTyConKindRepBinds"
                        (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tycon SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Type
tyConKind TyCon
tycon) SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
kind)
       let ctx :: CmEnv
ctx = [Var] -> CmEnv
mkDeBruijnContext ((TyCoVarBinder -> Var) -> [TyCoVarBinder] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map TyCoVarBinder -> Var
forall tv argf. VarBndr tv argf -> tv
binderVar [TyCoVarBinder]
bndrs)
       GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
kind_rep <- TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
getKindRep TypeableStuff
stuff CmEnv
ctx Type
kind

       -- Make the TyCon binding
       let tycon_rep_rhs :: LHsExpr (GhcPass 'Typechecked)
tycon_rep_rhs = TypeableStuff
-> TypeRepTodo
-> TyCon
-> LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked)
mkTyConRepTyConRHS TypeableStuff
stuff TypeRepTodo
todo TyCon
tycon LHsExpr (GhcPass 'Typechecked)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
kind_rep
           tycon_rep_bind :: LHsBind (GhcPass 'Typechecked)
tycon_rep_bind = IdP (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsBind (GhcPass 'Typechecked)
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind IdP (GhcPass 'Typechecked)
Var
tycon_rep_id LHsExpr (GhcPass 'Typechecked)
tycon_rep_rhs
       Bag
  (GenLocated
     SrcSpanAnnA
     (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))
-> KindRepM
     (Bag
        (GenLocated
           SrcSpanAnnA
           (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))))
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag
   (GenLocated
      SrcSpanAnnA
      (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))
 -> KindRepM
      (Bag
         (GenLocated
            SrcSpanAnnA
            (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))))
-> Bag
     (GenLocated
        SrcSpanAnnA
        (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))
-> KindRepM
     (Bag
        (GenLocated
           SrcSpanAnnA
           (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))))
forall a b. (a -> b) -> a -> b
$ GenLocated
  SrcSpanAnnA
  (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
-> Bag
     (GenLocated
        SrcSpanAnnA
        (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))
forall a. a -> Bag a
unitBag LHsBind (GhcPass 'Typechecked)
GenLocated
  SrcSpanAnnA
  (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
tycon_rep_bind

-- | Is a particular 'TyCon' representable by @Typeable@?. These exclude type
-- families and polytypes.
tyConIsTypeable :: TyCon -> Bool
tyConIsTypeable :: TyCon -> Bool
tyConIsTypeable TyCon
tc =
       Maybe Name -> Bool
forall a. Maybe a -> Bool
isJust (TyCon -> Maybe Name
tyConRepName_maybe TyCon
tc)
    Bool -> Bool -> Bool
&& Type -> Bool
kindIsTypeable (Type -> Type
dropForAlls (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ TyCon -> Type
tyConKind TyCon
tc)

-- | Is a particular 'Kind' representable by @Typeable@? Here we look for
-- polytypes and types containing casts (which may be, for instance, a type
-- family).
kindIsTypeable :: Kind -> Bool
-- We handle types of the form (TYPE LiftedRep) specifically to avoid
-- looping on (tyConIsTypeable RuntimeRep). We used to consider (TYPE rr)
-- to be typeable without inspecting rr, but this exhibits bad behavior
-- when rr is a type family.
kindIsTypeable :: Type -> Bool
kindIsTypeable Type
ty
  | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty         = Type -> Bool
kindIsTypeable Type
ty'
kindIsTypeable Type
ty
  | Type -> Bool
isLiftedTypeKind Type
ty             = Bool
True
kindIsTypeable (TyVarTy Var
_)          = Bool
True
kindIsTypeable (AppTy Type
a Type
b)          = Type -> Bool
kindIsTypeable Type
a Bool -> Bool -> Bool
&& Type -> Bool
kindIsTypeable Type
b
kindIsTypeable (FunTy AnonArgFlag
_ Type
w Type
a Type
b)      = Type -> Bool
kindIsTypeable Type
w Bool -> Bool -> Bool
&&
                                      Type -> Bool
kindIsTypeable Type
a Bool -> Bool -> Bool
&&
                                      Type -> Bool
kindIsTypeable Type
b
kindIsTypeable (TyConApp TyCon
tc [Type]
args)   = TyCon -> Bool
tyConIsTypeable TyCon
tc
                                   Bool -> Bool -> Bool
&& (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
kindIsTypeable [Type]
args
kindIsTypeable (ForAllTy{})         = Bool
False
kindIsTypeable (LitTy TyLit
_)            = Bool
True
kindIsTypeable (CastTy{})           = Bool
False
  -- See Note [Typeable instances for casted types]
kindIsTypeable (CoercionTy{})       = Bool
False

-- | Maps kinds to 'KindRep' bindings. This binding may either be defined in
-- some other module (in which case the @Maybe (LHsExpr Id@ will be 'Nothing')
-- or a binding which we generated in the current module (in which case it will
-- be 'Just' the RHS of the binding).
type KindRepEnv = TypeMap (Id, Maybe (LHsExpr GhcTc))

-- | A monad within which we will generate 'KindRep's. Here we keep an
-- environment containing 'KindRep's which we've already generated so we can
-- re-use them opportunistically.
newtype KindRepM a = KindRepM { forall a. KindRepM a -> StateT KindRepEnv TcRn a
unKindRepM :: StateT KindRepEnv TcRn a }
                   deriving ((forall a b. (a -> b) -> KindRepM a -> KindRepM b)
-> (forall a b. a -> KindRepM b -> KindRepM a) -> Functor KindRepM
forall a b. a -> KindRepM b -> KindRepM a
forall a b. (a -> b) -> KindRepM a -> KindRepM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> KindRepM a -> KindRepM b
fmap :: forall a b. (a -> b) -> KindRepM a -> KindRepM b
$c<$ :: forall a b. a -> KindRepM b -> KindRepM a
<$ :: forall a b. a -> KindRepM b -> KindRepM a
Functor, Functor KindRepM
Functor KindRepM
-> (forall a. a -> KindRepM a)
-> (forall a b. KindRepM (a -> b) -> KindRepM a -> KindRepM b)
-> (forall a b c.
    (a -> b -> c) -> KindRepM a -> KindRepM b -> KindRepM c)
-> (forall a b. KindRepM a -> KindRepM b -> KindRepM b)
-> (forall a b. KindRepM a -> KindRepM b -> KindRepM a)
-> Applicative KindRepM
forall a. a -> KindRepM a
forall a b. KindRepM a -> KindRepM b -> KindRepM a
forall a b. KindRepM a -> KindRepM b -> KindRepM b
forall a b. KindRepM (a -> b) -> KindRepM a -> KindRepM b
forall a b c.
(a -> b -> c) -> KindRepM a -> KindRepM b -> KindRepM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> KindRepM a
pure :: forall a. a -> KindRepM a
$c<*> :: forall a b. KindRepM (a -> b) -> KindRepM a -> KindRepM b
<*> :: forall a b. KindRepM (a -> b) -> KindRepM a -> KindRepM b
$cliftA2 :: forall a b c.
(a -> b -> c) -> KindRepM a -> KindRepM b -> KindRepM c
liftA2 :: forall a b c.
(a -> b -> c) -> KindRepM a -> KindRepM b -> KindRepM c
$c*> :: forall a b. KindRepM a -> KindRepM b -> KindRepM b
*> :: forall a b. KindRepM a -> KindRepM b -> KindRepM b
$c<* :: forall a b. KindRepM a -> KindRepM b -> KindRepM a
<* :: forall a b. KindRepM a -> KindRepM b -> KindRepM a
Applicative, Applicative KindRepM
Applicative KindRepM
-> (forall a b. KindRepM a -> (a -> KindRepM b) -> KindRepM b)
-> (forall a b. KindRepM a -> KindRepM b -> KindRepM b)
-> (forall a. a -> KindRepM a)
-> Monad KindRepM
forall a. a -> KindRepM a
forall a b. KindRepM a -> KindRepM b -> KindRepM b
forall a b. KindRepM a -> (a -> KindRepM b) -> KindRepM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. KindRepM a -> (a -> KindRepM b) -> KindRepM b
>>= :: forall a b. KindRepM a -> (a -> KindRepM b) -> KindRepM b
$c>> :: forall a b. KindRepM a -> KindRepM b -> KindRepM b
>> :: forall a b. KindRepM a -> KindRepM b -> KindRepM b
$creturn :: forall a. a -> KindRepM a
return :: forall a. a -> KindRepM a
Monad)

liftTc :: TcRn a -> KindRepM a
liftTc :: forall a. TcRn a -> KindRepM a
liftTc = StateT KindRepEnv TcRn a -> KindRepM a
StateT
  (TypeMap
     (Var,
      Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
  TcRn
  a
-> KindRepM a
forall a. StateT KindRepEnv TcRn a -> KindRepM a
KindRepM (StateT
   (TypeMap
      (Var,
       Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
   TcRn
   a
 -> KindRepM a)
-> (TcRn a
    -> StateT
         (TypeMap
            (Var,
             Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
         TcRn
         a)
-> TcRn a
-> KindRepM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcRn a
-> StateT
     (TypeMap
        (Var,
         Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
     TcRn
     a
forall (m :: * -> *) a.
Monad m =>
m a
-> StateT
     (TypeMap
        (Var,
         Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
     m
     a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | We generate @KindRep@s for a few common kinds in @GHC.Types@ so that they
-- can be reused across modules.
builtInKindReps :: [(Kind, Name)]
builtInKindReps :: [(Type, Name)]
builtInKindReps =
    [ (Type
star, Name
starKindRepName)
    , (Type -> Type -> Type
mkVisFunTyMany Type
star Type
star, Name
starArrStarKindRepName)
    , ([Type] -> Type -> Type
mkVisFunTysMany [Type
star, Type
star] Type
star, Name
starArrStarArrStarKindRepName)
    ]
  where
    star :: Type
star = Type
liftedTypeKind

initialKindRepEnv :: TcRn KindRepEnv
initialKindRepEnv :: TcRn KindRepEnv
initialKindRepEnv = (TypeMap
   (Var,
    Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
 -> (Type, Name)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (TypeMap
         (Var,
          Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))))
-> TypeMap
     (Var,
      Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> [(Type, Name)]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TypeMap
        (Var,
         Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM TypeMap
  (Var,
   Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> (Type, Name)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TypeMap
        (Var,
         Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
forall {a}.
TypeMap (Var, Maybe a)
-> (Type, Name)
-> IOEnv (Env TcGblEnv TcLclEnv) (TypeMap (Var, Maybe a))
add_kind_rep TypeMap
  (Var,
   Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
forall a. TypeMap a
emptyTypeMap [(Type, Name)]
builtInKindReps
  where
    add_kind_rep :: TypeMap (Var, Maybe a)
-> (Type, Name)
-> IOEnv (Env TcGblEnv TcLclEnv) (TypeMap (Var, Maybe a))
add_kind_rep TypeMap (Var, Maybe a)
acc (Type
k,Name
n) = do
        Var
id <- Name -> TcM Var
tcLookupId Name
n
        TypeMap (Var, Maybe a)
-> IOEnv (Env TcGblEnv TcLclEnv) (TypeMap (Var, Maybe a))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeMap (Var, Maybe a)
 -> IOEnv (Env TcGblEnv TcLclEnv) (TypeMap (Var, Maybe a)))
-> TypeMap (Var, Maybe a)
-> IOEnv (Env TcGblEnv TcLclEnv) (TypeMap (Var, Maybe a))
forall a b. (a -> b) -> a -> b
$! TypeMap (Var, Maybe a)
-> Type -> (Var, Maybe a) -> TypeMap (Var, Maybe a)
forall a. TypeMap a -> Type -> a -> TypeMap a
extendTypeMap TypeMap (Var, Maybe a)
acc Type
k (Var
id, Maybe a
forall a. Maybe a
Nothing)

-- | Performed while compiling "GHC.Types" to generate the built-in 'KindRep's.
mkExportedKindReps :: TypeableStuff
                   -> [(Kind, Id)]  -- ^ the kinds to generate bindings for
                   -> KindRepM ()
mkExportedKindReps :: TypeableStuff -> [(Type, Var)] -> KindRepM ()
mkExportedKindReps TypeableStuff
stuff = ((Type, Var) -> KindRepM ()) -> [(Type, Var)] -> KindRepM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Type, Var) -> KindRepM ()
kindrep_binding
  where
    empty_scope :: CmEnv
empty_scope = [Var] -> CmEnv
mkDeBruijnContext []

    kindrep_binding :: (Kind, Id) -> KindRepM ()
    kindrep_binding :: (Type, Var) -> KindRepM ()
kindrep_binding (Type
kind, Var
rep_bndr) = do
        -- We build the binding manually here instead of using mkKindRepRhs
        -- since the latter would find the built-in 'KindRep's in the
        -- 'KindRepEnv' (by virtue of being in 'initialKindRepEnv').
        GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rhs <- TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
mkKindRepRhs TypeableStuff
stuff CmEnv
empty_scope Type
kind
        CmEnv
-> Type -> Var -> LHsExpr (GhcPass 'Typechecked) -> KindRepM ()
addKindRepBind CmEnv
empty_scope Type
kind Var
rep_bndr LHsExpr (GhcPass 'Typechecked)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rhs

addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr GhcTc -> KindRepM ()
addKindRepBind :: CmEnv
-> Type -> Var -> LHsExpr (GhcPass 'Typechecked) -> KindRepM ()
addKindRepBind CmEnv
in_scope Type
k Var
bndr LHsExpr (GhcPass 'Typechecked)
rhs =
    StateT KindRepEnv TcRn () -> KindRepM ()
forall a. StateT KindRepEnv TcRn a -> KindRepM a
KindRepM (StateT KindRepEnv TcRn () -> KindRepM ())
-> StateT KindRepEnv TcRn () -> KindRepM ()
forall a b. (a -> b) -> a -> b
$ (KindRepEnv -> KindRepEnv) -> StateT KindRepEnv TcRn ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((KindRepEnv -> KindRepEnv) -> StateT KindRepEnv TcRn ())
-> (KindRepEnv -> KindRepEnv) -> StateT KindRepEnv TcRn ()
forall a b. (a -> b) -> a -> b
$
    \KindRepEnv
env -> TypeMap
  (Var,
   Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> CmEnv
-> Type
-> (Var,
    Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> TypeMap
     (Var,
      Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
forall a. TypeMap a -> CmEnv -> Type -> a -> TypeMap a
extendTypeMapWithScope KindRepEnv
TypeMap
  (Var,
   Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
env CmEnv
in_scope Type
k (Var
bndr, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a. a -> Maybe a
Just LHsExpr (GhcPass 'Typechecked)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rhs)

-- | Run a 'KindRepM' and add the produced 'KindRep's to the typechecking
-- environment.
runKindRepM :: KindRepM a -> TcRn (TcGblEnv, a)
runKindRepM :: forall a. KindRepM a -> TcRn (TcGblEnv, a)
runKindRepM (KindRepM StateT KindRepEnv TcRn a
action) = do
    TypeMap
  (Var,
   Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
kindRepEnv <- TcRn KindRepEnv
IOEnv
  (Env TcGblEnv TcLclEnv)
  (TypeMap
     (Var,
      Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
initialKindRepEnv
    (a
res, TypeMap
  (Var,
   Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
reps_env) <- StateT
  (TypeMap
     (Var,
      Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
  TcRn
  a
-> TypeMap
     (Var,
      Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (a,
      TypeMap
        (Var,
         Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT KindRepEnv TcRn a
StateT
  (TypeMap
     (Var,
      Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
  TcRn
  a
action TypeMap
  (Var,
   Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
kindRepEnv
    let rep_binds :: [(Var, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))]
rep_binds = ((Var,
  Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
 -> [(Var, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))]
 -> [(Var, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))])
-> [(Var, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))]
-> TypeMap
     (Var,
      Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> [(Var, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))]
forall a b. (a -> b -> b) -> b -> TypeMap a -> b
foldTypeMap (Var,
 Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> [(Var, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))]
-> [(Var, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))]
forall {a} {b}. (a, Maybe b) -> [(a, b)] -> [(a, b)]
to_bind_pair [] TypeMap
  (Var,
   Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
reps_env
        to_bind_pair :: (a, Maybe b) -> [(a, b)] -> [(a, b)]
to_bind_pair (a
bndr, Just b
rhs) [(a, b)]
rest = (a
bndr, b
rhs) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)]
rest
        to_bind_pair (a
_, Maybe b
Nothing) [(a, b)]
rest = [(a, b)]
rest
    TcGblEnv
tcg_env <- [Var] -> TcM TcGblEnv -> TcM TcGblEnv
forall a. [Var] -> TcM a -> TcM a
tcExtendGlobalValEnv (((Var, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
 -> Var)
-> [(Var, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))]
-> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
-> Var
forall a b. (a, b) -> a
fst [(Var, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))]
rep_binds) TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
    let binds :: [GenLocated
   SrcSpanAnnA
   (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))]
binds = ((Var, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
 -> GenLocated
      SrcSpanAnnA
      (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))
-> [(Var, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))]
-> [GenLocated
      SrcSpanAnnA
      (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))]
forall a b. (a -> b) -> [a] -> [b]
map ((Var
 -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
 -> GenLocated
      SrcSpanAnnA
      (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))
-> (Var, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
-> GenLocated
     SrcSpanAnnA
     (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry IdP (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsBind (GhcPass 'Typechecked)
Var
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> GenLocated
     SrcSpanAnnA
     (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind) [(Var, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))]
rep_binds
        tcg_env' :: TcGblEnv
tcg_env' = TcGblEnv
tcg_env TcGblEnv -> [LHsBinds (GhcPass 'Typechecked)] -> TcGblEnv
`addTypecheckedBinds` [[GenLocated
   SrcSpanAnnA
   (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))]
-> Bag
     (GenLocated
        SrcSpanAnnA
        (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))
forall a. [a] -> Bag a
listToBag [GenLocated
   SrcSpanAnnA
   (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))]
binds]
    (TcGblEnv, a) -> TcRn (TcGblEnv, a)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env', a
res)

-- | Produce or find a 'KindRep' for the given kind.
getKindRep :: TypeableStuff -> CmEnv  -- ^ in-scope kind variables
           -> Kind   -- ^ the kind we want a 'KindRep' for
           -> KindRepM (LHsExpr GhcTc)
getKindRep :: TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
getKindRep stuff :: TypeableStuff
stuff@(Stuff {TyCon
Platform
DataCon
FastString -> LHsExpr (GhcPass 'Typechecked)
platform :: TypeableStuff -> Platform
trTyConDataCon :: TypeableStuff -> DataCon
trNameLit :: TypeableStuff -> FastString -> LHsExpr (GhcPass 'Typechecked)
kindRepTyCon :: TypeableStuff -> TyCon
kindRepTyConAppDataCon :: TypeableStuff -> DataCon
kindRepVarDataCon :: TypeableStuff -> DataCon
kindRepAppDataCon :: TypeableStuff -> DataCon
kindRepFunDataCon :: TypeableStuff -> DataCon
kindRepTYPEDataCon :: TypeableStuff -> DataCon
kindRepTypeLitSDataCon :: TypeableStuff -> DataCon
typeLitSymbolDataCon :: TypeableStuff -> DataCon
typeLitCharDataCon :: TypeableStuff -> DataCon
typeLitNatDataCon :: TypeableStuff -> DataCon
platform :: Platform
trTyConDataCon :: DataCon
trNameLit :: FastString -> LHsExpr (GhcPass 'Typechecked)
kindRepTyCon :: TyCon
kindRepTyConAppDataCon :: DataCon
kindRepVarDataCon :: DataCon
kindRepAppDataCon :: DataCon
kindRepFunDataCon :: DataCon
kindRepTYPEDataCon :: DataCon
kindRepTypeLitSDataCon :: DataCon
typeLitSymbolDataCon :: DataCon
typeLitCharDataCon :: DataCon
typeLitNatDataCon :: DataCon
..}) CmEnv
in_scope = Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
go
  where
    go :: Kind -> KindRepM (LHsExpr GhcTc)
    go :: Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
go = StateT
  KindRepEnv
  TcRn
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
StateT
  (TypeMap
     (Var,
      Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
  TcRn
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a. StateT KindRepEnv TcRn a -> KindRepM a
KindRepM (StateT
   (TypeMap
      (Var,
       Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
   TcRn
   (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
 -> KindRepM
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> (Type
    -> StateT
         (TypeMap
            (Var,
             Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
         TcRn
         (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> Type
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeMap
   (Var,
    Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)),
       TypeMap
         (Var,
          Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))))
-> StateT
     (TypeMap
        (Var,
         Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
     TcRn
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((TypeMap
    (Var,
     Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
  -> IOEnv
       (Env TcGblEnv TcLclEnv)
       (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)),
        TypeMap
          (Var,
           Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))))
 -> StateT
      (TypeMap
         (Var,
          Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
      TcRn
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> (Type
    -> TypeMap
         (Var,
          Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)),
          TypeMap
            (Var,
             Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))))
-> Type
-> StateT
     (TypeMap
        (Var,
         Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
     TcRn
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type
-> KindRepEnv -> TcRn (LHsExpr (GhcPass 'Typechecked), KindRepEnv)
Type
-> TypeMap
     (Var,
      Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)),
      TypeMap
        (Var,
         Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
go'

    go' :: Kind -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv)
    go' :: Type
-> KindRepEnv -> TcRn (LHsExpr (GhcPass 'Typechecked), KindRepEnv)
go' Type
k KindRepEnv
env
        -- Look through type synonyms
      | Just Type
k' <- Type -> Maybe Type
tcView Type
k = Type
-> KindRepEnv -> TcRn (LHsExpr (GhcPass 'Typechecked), KindRepEnv)
go' Type
k' KindRepEnv
env

        -- We've already generated the needed KindRep
      | Just (Var
id, Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
_) <- TypeMap
  (Var,
   Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> CmEnv
-> Type
-> Maybe
     (Var,
      Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
forall a. TypeMap a -> CmEnv -> Type -> Maybe a
lookupTypeMapWithScope KindRepEnv
TypeMap
  (Var,
   Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
env CmEnv
in_scope Type
k
      = (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)),
 TypeMap
   (Var,
    Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)),
      TypeMap
        (Var,
         Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IdP (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Typechecked)
Var
id, KindRepEnv
TypeMap
  (Var,
   Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
env)

        -- We need to construct a new KindRep binding
      | Bool
otherwise
      = do -- Place a NOINLINE pragma on KindReps since they tend to be quite
           -- large and bloat interface files.
           Var
rep_bndr <- (Var -> InlinePragma -> Var
`setInlinePragma` InlinePragma
neverInlinePragma)
                   (Var -> Var) -> TcM Var -> TcM Var
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FastString -> Type -> Type -> TcM Var
forall gbl lcl. FastString -> Type -> Type -> TcRnIf gbl lcl Var
newSysLocalId (String -> FastString
fsLit String
"$krep") Type
Many (TyCon -> Type
mkTyConTy TyCon
kindRepTyCon)

           -- do we need to tie a knot here?
           (StateT
   (TypeMap
      (Var,
       Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
   TcRn
   (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
 -> TypeMap
      (Var,
       Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)),
       TypeMap
         (Var,
          Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))))
-> TypeMap
     (Var,
      Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> StateT
     (TypeMap
        (Var,
         Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
     TcRn
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)),
      TypeMap
        (Var,
         Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
  (TypeMap
     (Var,
      Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
  TcRn
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
-> TypeMap
     (Var,
      Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)),
      TypeMap
        (Var,
         Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT KindRepEnv
TypeMap
  (Var,
   Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
env (StateT
   (TypeMap
      (Var,
       Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
   TcRn
   (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)),
       TypeMap
         (Var,
          Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))))
-> StateT
     (TypeMap
        (Var,
         Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
     TcRn
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)),
      TypeMap
        (Var,
         Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))))
forall a b. (a -> b) -> a -> b
$ KindRepM (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
-> StateT
     KindRepEnv
     TcRn
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a. KindRepM a -> StateT KindRepEnv TcRn a
unKindRepM (KindRepM (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
 -> StateT
      KindRepEnv
      TcRn
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
-> StateT
     KindRepEnv
     TcRn
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a b. (a -> b) -> a -> b
$ do
               GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rhs <- TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
mkKindRepRhs TypeableStuff
stuff CmEnv
in_scope Type
k
               CmEnv
-> Type -> Var -> LHsExpr (GhcPass 'Typechecked) -> KindRepM ()
addKindRepBind CmEnv
in_scope Type
k Var
rep_bndr LHsExpr (GhcPass 'Typechecked)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rhs
               GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
 -> KindRepM
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a b. (a -> b) -> a -> b
$ IdP (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Typechecked)
Var
rep_bndr

-- | Construct the right-hand-side of the 'KindRep' for the given 'Kind' and
-- in-scope kind variable set.
mkKindRepRhs :: TypeableStuff
             -> CmEnv       -- ^ in-scope kind variables
             -> Kind        -- ^ the kind we want a 'KindRep' for
             -> KindRepM (LHsExpr GhcTc) -- ^ RHS expression
mkKindRepRhs :: TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
mkKindRepRhs stuff :: TypeableStuff
stuff@(Stuff {TyCon
Platform
DataCon
FastString -> LHsExpr (GhcPass 'Typechecked)
platform :: TypeableStuff -> Platform
trTyConDataCon :: TypeableStuff -> DataCon
trNameLit :: TypeableStuff -> FastString -> LHsExpr (GhcPass 'Typechecked)
kindRepTyCon :: TypeableStuff -> TyCon
kindRepTyConAppDataCon :: TypeableStuff -> DataCon
kindRepVarDataCon :: TypeableStuff -> DataCon
kindRepAppDataCon :: TypeableStuff -> DataCon
kindRepFunDataCon :: TypeableStuff -> DataCon
kindRepTYPEDataCon :: TypeableStuff -> DataCon
kindRepTypeLitSDataCon :: TypeableStuff -> DataCon
typeLitSymbolDataCon :: TypeableStuff -> DataCon
typeLitCharDataCon :: TypeableStuff -> DataCon
typeLitNatDataCon :: TypeableStuff -> DataCon
platform :: Platform
trTyConDataCon :: DataCon
trNameLit :: FastString -> LHsExpr (GhcPass 'Typechecked)
kindRepTyCon :: TyCon
kindRepTyConAppDataCon :: DataCon
kindRepVarDataCon :: DataCon
kindRepAppDataCon :: DataCon
kindRepFunDataCon :: DataCon
kindRepTYPEDataCon :: DataCon
kindRepTypeLitSDataCon :: DataCon
typeLitSymbolDataCon :: DataCon
typeLitCharDataCon :: DataCon
typeLitNatDataCon :: DataCon
..}) CmEnv
in_scope = Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
Type
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
new_kind_rep_shortcut
  where
    new_kind_rep_shortcut :: Type
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
new_kind_rep_shortcut Type
k
        -- We handle (TYPE LiftedRep) etc separately to make it
        -- clear to consumers (e.g. serializers) that there is
        -- a loop here (as TYPE :: RuntimeRep -> TYPE 'LiftedRep)
      | Bool -> Bool
not (Type -> Bool
tcIsConstraintKind Type
k)
              -- Typeable respects the Constraint/Type distinction
              -- so do not follow the special case here
      , Just Type
arg <- (() :: Constraint) => Type -> Maybe Type
Type -> Maybe Type
kindRep_maybe Type
k
      = case (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
arg of
          Just (TyCon
tc, [])
            | Just DataCon
dc <- TyCon -> Maybe DataCon
isPromotedDataCon_maybe TyCon
tc
              -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
 -> KindRepM
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepTYPEDataCon LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
dc

          Just (TyCon
rep, [Type
levArg])
            | Just DataCon
dcRep <- TyCon -> Maybe DataCon
isPromotedDataCon_maybe TyCon
rep
            , Just (TyCon
lev, []) <- (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
levArg
            , Just DataCon
dcLev <- TyCon -> Maybe DataCon
isPromotedDataCon_maybe TyCon
lev
              -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
 -> KindRepM
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepTYPEDataCon LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` (DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
dcRep LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
dcLev)

          Maybe (TyCon, [Type])
_   -> Type
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
new_kind_rep Type
k
      | Bool
otherwise = Type
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
new_kind_rep Type
k


    new_kind_rep :: Type
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
new_kind_rep (TyVarTy Var
v)
      | Just Int
idx <- CmEnv -> Var -> Maybe Int
lookupCME CmEnv
in_scope Var
v
      = GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
 -> KindRepM
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepVarDataCon
                 LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` Integer -> LHsExpr (GhcPass 'Typechecked)
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
idx)
      | Bool
otherwise
      = String
-> SDoc
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTyConKindRepBinds.go(tyvar)" (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v)

    new_kind_rep (AppTy Type
t1 Type
t2)
      = do GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rep1 <- TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
getKindRep TypeableStuff
stuff CmEnv
in_scope Type
t1
           GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rep2 <- TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
getKindRep TypeableStuff
stuff CmEnv
in_scope Type
t2
           GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
 -> KindRepM
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepAppDataCon
                    LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr (GhcPass 'Typechecked)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rep1 LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr (GhcPass 'Typechecked)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rep2

    new_kind_rep k :: Type
k@(TyConApp TyCon
tc [Type]
tys)
      | Just Name
rep_name <- TyCon -> Maybe Name
tyConRepName_maybe TyCon
tc
      = do Var
rep_id <- TcM Var -> KindRepM Var
forall a. TcRn a -> KindRepM a
liftTc (TcM Var -> KindRepM Var) -> TcM Var -> KindRepM Var
forall a b. (a -> b) -> a -> b
$ Name -> TcM Var
forall (m :: * -> *). MonadThings m => Name -> m Var
lookupId Name
rep_name
           [GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))]
tys' <- (Type
 -> KindRepM
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> [Type]
-> KindRepM
     [GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
getKindRep TypeableStuff
stuff CmEnv
in_scope) [Type]
tys
           GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
 -> KindRepM
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepTyConAppDataCon
                    LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` IdP (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Typechecked)
Var
rep_id
                    LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` Type
-> [LHsExpr (GhcPass 'Typechecked)]
-> LHsExpr (GhcPass 'Typechecked)
mkList (TyCon -> Type
mkTyConTy TyCon
kindRepTyCon) [LHsExpr (GhcPass 'Typechecked)]
[GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))]
tys'
      | Bool
otherwise
      = String
-> SDoc
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTyConKindRepBinds(TyConApp)" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
k)

    new_kind_rep (ForAllTy (Bndr Var
var ArgFlag
_) Type
ty)
      = String
-> SDoc
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTyConKindRepBinds(ForAllTy)" (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
var SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

    new_kind_rep (FunTy AnonArgFlag
_ Type
_ Type
t1 Type
t2)
      = do GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rep1 <- TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
getKindRep TypeableStuff
stuff CmEnv
in_scope Type
t1
           GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rep2 <- TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
getKindRep TypeableStuff
stuff CmEnv
in_scope Type
t2
           GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
 -> KindRepM
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepFunDataCon
                    LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr (GhcPass 'Typechecked)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rep1 LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr (GhcPass 'Typechecked)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rep2

    new_kind_rep (LitTy (NumTyLit Integer
n))
      = GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
 -> KindRepM
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepTypeLitSDataCon
                 LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
typeLitNatDataCon
                 LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (FastString -> HsLit (GhcPass 'Typechecked)
forall (p :: Pass). FastString -> HsLit (GhcPass p)
mkHsStringPrimLit (FastString -> HsLit (GhcPass 'Typechecked))
-> FastString -> HsLit (GhcPass 'Typechecked)
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show Integer
n)

    new_kind_rep (LitTy (StrTyLit FastString
s))
      = GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
 -> KindRepM
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepTypeLitSDataCon
                 LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
typeLitSymbolDataCon
                 LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (FastString -> HsLit (GhcPass 'Typechecked)
forall (p :: Pass). FastString -> HsLit (GhcPass p)
mkHsStringPrimLit (FastString -> HsLit (GhcPass 'Typechecked))
-> FastString -> HsLit (GhcPass 'Typechecked)
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ FastString -> String
forall a. Show a => a -> String
show FastString
s)

    new_kind_rep (LitTy (CharTyLit Char
c))
      = GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
 -> KindRepM
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepTypeLitSDataCon
                 LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
typeLitCharDataCon
                 LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (Char -> HsLit (GhcPass 'Typechecked)
forall (p :: Pass). Char -> HsLit (GhcPass p)
mkHsCharPrimLit Char
c)

    -- See Note [Typeable instances for casted types]
    new_kind_rep (CastTy Type
ty KindCoercion
co)
      = String
-> SDoc
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTyConKindRepBinds.go(cast)" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
$$ KindCoercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr KindCoercion
co)

    new_kind_rep (CoercionTy KindCoercion
co)
      = String
-> SDoc
-> KindRepM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTyConKindRepBinds.go(coercion)" (KindCoercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr KindCoercion
co)

-- | Produce the right-hand-side of a @TyCon@ representation.
mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo
                   -> TyCon      -- ^ the 'TyCon' we are producing a binding for
                   -> LHsExpr GhcTc -- ^ its 'KindRep'
                   -> LHsExpr GhcTc
mkTyConRepTyConRHS :: TypeableStuff
-> TypeRepTodo
-> TyCon
-> LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked)
mkTyConRepTyConRHS (Stuff {TyCon
Platform
DataCon
FastString -> LHsExpr (GhcPass 'Typechecked)
platform :: TypeableStuff -> Platform
trTyConDataCon :: TypeableStuff -> DataCon
trNameLit :: TypeableStuff -> FastString -> LHsExpr (GhcPass 'Typechecked)
kindRepTyCon :: TypeableStuff -> TyCon
kindRepTyConAppDataCon :: TypeableStuff -> DataCon
kindRepVarDataCon :: TypeableStuff -> DataCon
kindRepAppDataCon :: TypeableStuff -> DataCon
kindRepFunDataCon :: TypeableStuff -> DataCon
kindRepTYPEDataCon :: TypeableStuff -> DataCon
kindRepTypeLitSDataCon :: TypeableStuff -> DataCon
typeLitSymbolDataCon :: TypeableStuff -> DataCon
typeLitCharDataCon :: TypeableStuff -> DataCon
typeLitNatDataCon :: TypeableStuff -> DataCon
platform :: Platform
trTyConDataCon :: DataCon
trNameLit :: FastString -> LHsExpr (GhcPass 'Typechecked)
kindRepTyCon :: TyCon
kindRepTyConAppDataCon :: DataCon
kindRepVarDataCon :: DataCon
kindRepAppDataCon :: DataCon
kindRepFunDataCon :: DataCon
kindRepTYPEDataCon :: DataCon
kindRepTypeLitSDataCon :: DataCon
typeLitSymbolDataCon :: DataCon
typeLitCharDataCon :: DataCon
typeLitNatDataCon :: DataCon
..}) TypeRepTodo
todo TyCon
tycon LHsExpr (GhcPass 'Typechecked)
kind_rep
  =           DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
trTyConDataCon
    LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (XHsWord64Prim (GhcPass 'Typechecked)
-> Integer -> HsLit (GhcPass 'Typechecked)
forall x. XHsWord64Prim x -> Integer -> HsLit x
HsWord64Prim XHsWord64Prim (GhcPass 'Typechecked)
SourceText
NoSourceText (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
high))
    LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (XHsWord64Prim (GhcPass 'Typechecked)
-> Integer -> HsLit (GhcPass 'Typechecked)
forall x. XHsWord64Prim x -> Integer -> HsLit x
HsWord64Prim XHsWord64Prim (GhcPass 'Typechecked)
SourceText
NoSourceText (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
low))
    LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` TypeRepTodo -> LHsExpr (GhcPass 'Typechecked)
mod_rep_expr TypeRepTodo
todo
    LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` FastString -> LHsExpr (GhcPass 'Typechecked)
trNameLit (String -> FastString
mkFastString String
tycon_str)
    LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (XHsIntPrim (GhcPass 'Typechecked)
-> Integer -> HsLit (GhcPass 'Typechecked)
forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim XHsIntPrim (GhcPass 'Typechecked)
SourceText
NoSourceText (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n_kind_vars))
    LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr (GhcPass 'Typechecked)
kind_rep
  where
    n_kind_vars :: Int
n_kind_vars = [TyConBinder] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TyConBinder] -> Int) -> [TyConBinder] -> Int
forall a b. (a -> b) -> a -> b
$ (TyConBinder -> Bool) -> [TyConBinder] -> [TyConBinder]
forall a. (a -> Bool) -> [a] -> [a]
filter TyConBinder -> Bool
isNamedTyConBinder (TyCon -> [TyConBinder]
tyConBinders TyCon
tycon)
    tycon_str :: String
tycon_str = String -> String
add_tick (OccName -> String
occNameString (TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName TyCon
tycon))
    add_tick :: String -> String
add_tick String
s | TyCon -> Bool
isPromotedDataCon TyCon
tycon = Char
'\'' Char -> String -> String
forall a. a -> [a] -> [a]
: String
s
               | Bool
otherwise               = String
s

    -- This must match the computation done in
    -- Data.Typeable.Internal.mkTyConFingerprint.
    Fingerprint Word64
high Word64
low = [Fingerprint] -> Fingerprint
fingerprintFingerprints [ TypeRepTodo -> Fingerprint
pkg_fingerprint TypeRepTodo
todo
                                                   , TypeRepTodo -> Fingerprint
mod_fingerprint TypeRepTodo
todo
                                                   , String -> Fingerprint
fingerprintString String
tycon_str
                                                   ]

{-
Note [Representing TyCon kinds: KindRep]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
One of the operations supported by Typeable is typeRepKind,

    typeRepKind :: TypeRep (a :: k) -> TypeRep k

Implementing this is a bit tricky for poly-kinded types like

    data Proxy (a :: k) :: Type
    -- Proxy :: forall k. k -> Type

The TypeRep encoding of `Proxy Type Int` looks like this:

    $tcProxy :: GHC.Types.TyCon
    $trInt   :: TypeRep Int
    TrType   :: TypeRep Type

    $trProxyType :: TypeRep (Proxy Type :: Type -> Type)
    $trProxyType = TrTyCon $tcProxy
                           [TrType]  -- kind variable instantiation
                           (tyConKind $tcProxy [TrType]) -- The TypeRep of
                                                         -- Type -> Type

    $trProxy :: TypeRep (Proxy Type Int)
    $trProxy = TrApp $trProxyType $trInt TrType

    $tkProxy :: GHC.Types.KindRep
    $tkProxy = KindRepFun (KindRepVar 0)
                          (KindRepTyConApp (KindRepTYPE LiftedRep) [])

Note how $trProxyType cannot use 'TrApp', because TypeRep cannot represent
polymorphic types.  So instead

 * $trProxyType uses 'TrTyCon' to apply Proxy to (the representations)
   of all its kind arguments. We can't represent a tycon that is
   applied to only some of its kind arguments.

 * In $tcProxy, the GHC.Types.TyCon structure for Proxy, we store a
   GHC.Types.KindRep, which represents the polymorphic kind of Proxy
       Proxy :: forall k. k->Type

 * A KindRep is just a recipe that we can instantiate with the
   argument kinds, using Data.Typeable.Internal.tyConKind and
   store in the relevant 'TypeRep' constructor.

   Data.Typeable.Internal.typeRepKind looks up the stored kinds.

 * In a KindRep, the kind variables are represented by 0-indexed
   de Bruijn numbers:

    type KindBndr = Int   -- de Bruijn index

    data KindRep = KindRepTyConApp TyCon [KindRep]
                 | KindRepVar !KindBndr
                 | KindRepApp KindRep KindRep
                 | KindRepFun KindRep KindRep
                 ...

Note [Typeable instances for casted types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
At present, GHC does not manufacture TypeReps for types containing casts
(#16835). In theory, GHC could do so today, but it might be dangerous tomorrow.

In today's GHC, we normalize all types before computing their TypeRep.
For example:

    type family F a
    type instance F Int = Type

    data D = forall (a :: F Int). MkD a

    tr :: TypeRep (MkD Bool)
    tr = typeRep

When computing the TypeRep for `MkD Bool` (or rather,
`MkD (Bool |> Sym (FInt[0]))`), we simply discard the cast to obtain the
TypeRep for `MkD Bool`.

Why does this work? If we have a type definition with casts, then the
only coercions that those casts can mention are either Refl, type family
axioms, built-in axioms, and coercions built from those roots. Therefore,
type family (and built-in) axioms will apply precisely when type normalization
succeeds (i.e, the type family applications are reducible). Therefore, it
is safe to ignore the cast entirely when constructing the TypeRep.

This approach would be fragile in a future where GHC permits other forms of
coercions to appear in casts (e.g., coercion quantification as described
in #15710). If GHC permits local assumptions to appear in casts that cannot be
reduced with conventional normalization, then discarding casts would become
unsafe. It would be unfortunate for the Typeable solver to become a roadblock
obstructing such a future, so we deliberately do not implement the ability
for TypeReps to represent types with casts at the moment.

If we do wish to allow this in the future, it will likely require modeling
casts and coercions in TypeReps themselves.
-}

mkList :: Type -> [LHsExpr GhcTc] -> LHsExpr GhcTc
mkList :: Type
-> [LHsExpr (GhcPass 'Typechecked)]
-> LHsExpr (GhcPass 'Typechecked)
mkList Type
ty = (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
 -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
 -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> [GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))]
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
consApp (Type -> LHsExpr (GhcPass 'Typechecked)
nilExpr Type
ty)
  where
    cons :: LHsExpr (GhcPass 'Typechecked)
cons = Type -> LHsExpr (GhcPass 'Typechecked)
consExpr Type
ty
    consApp :: LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
    consApp :: LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
consApp LHsExpr (GhcPass 'Typechecked)
x LHsExpr (GhcPass 'Typechecked)
xs = LHsExpr (GhcPass 'Typechecked)
cons LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr (GhcPass 'Typechecked)
x LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr (GhcPass 'Typechecked)
xs

    nilExpr :: Type -> LHsExpr GhcTc
    nilExpr :: Type -> LHsExpr (GhcPass 'Typechecked)
nilExpr Type
ty = HsWrapper
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
mkLHsWrap ([Type] -> HsWrapper
mkWpTyApps [Type
ty]) (DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
nilDataCon)

    consExpr :: Type -> LHsExpr GhcTc
    consExpr :: Type -> LHsExpr (GhcPass 'Typechecked)
consExpr Type
ty = HsWrapper
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
mkLHsWrap ([Type] -> HsWrapper
mkWpTyApps [Type
ty]) (DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
consDataCon)