{-# 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(..), TypeOrConstraint(..), 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 )
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
{
; TcGblEnv
tcg_env <- TcM TcGblEnv
mkModIdBindings
; (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
; 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
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
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 (FastString -> OccName
mkVarOccFS (String -> FastString
fsLit 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 GhcTc GhcTc)
mod_bind <- IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind IdP GhcTc
Var
mod_id (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Module -> TcM (LHsExpr GhcTc)
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 = Just mod_id }
TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
`addTypecheckedBinds` [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
mod_bind]) }
mkModIdRHS :: Module -> TcM (LHsExpr GhcTc)
mkModIdRHS :: Module -> TcM (LHsExpr GhcTc)
mkModIdRHS Module
mod
= do { DataCon
trModuleDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
trModuleDataConName
; FastString -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
trNameLit <- TcM (FastString -> LHsExpr GhcTc)
IOEnv
(Env TcGblEnv TcLclEnv)
(FastString -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
mkTrNameLit
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
trModuleDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` FastString -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
trNameLit (Unit -> FastString
forall u. IsUnitId u => u -> FastString
unitFS (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod))
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` FastString -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
trNameLit (ModuleName -> FastString
moduleNameFS (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod))
}
data TypeableTyCon
= TypeableTyCon
{ TypeableTyCon -> TyCon
tycon :: !TyCon
, TypeableTyCon -> Var
tycon_rep_id :: !Id
}
data TypeRepTodo
= TypeRepTodo
{ TypeRepTodo -> LHsExpr GhcTc
mod_rep_expr :: LHsExpr GhcTc
, TypeRepTodo -> Fingerprint
pkg_fingerprint :: !Fingerprint
, TypeRepTodo -> Fingerprint
mod_fingerprint :: !Fingerprint
, TypeRepTodo -> [TypeableTyCon]
todo_tycons :: [TypeableTyCon]
}
| ExportedKindRepsTodo [(Kind, Id)]
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
, 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
, 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 GhcTc
mod_rep_expr = IdP GhcTc -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcTc
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
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
; 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 GhcTc]
mk_binds todo :: TypeRepTodo
todo@(TypeRepTodo {}) =
(TypeableTyCon
-> KindRepM (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))))
-> [TypeableTyCon]
-> KindRepM [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
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 GhcTc)
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 GhcTc GhcTc))]
-> KindRepM [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
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 GhcTc GhcTc))]
-> KindRepM [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return []
; (TcGblEnv
gbl_env, [[Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]]
binds) <- TcGblEnv
-> TcRnIf
TcGblEnv
TcLclEnv
(TcGblEnv, [[Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]])
-> TcRnIf
TcGblEnv
TcLclEnv
(TcGblEnv, [[Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]])
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 GhcTc GhcTc))]])
-> TcRnIf
TcGblEnv
TcLclEnv
(TcGblEnv,
[[Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]]))
-> TcRnIf
TcGblEnv
TcLclEnv
(TcGblEnv, [[Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]])
-> TcRnIf
TcGblEnv
TcLclEnv
(TcGblEnv, [[Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]])
forall a b. (a -> b) -> a -> b
$ KindRepM [[Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]]
-> TcRnIf
TcGblEnv
TcLclEnv
(TcGblEnv, [[Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]])
forall a. KindRepM a -> TcRn (TcGblEnv, a)
runKindRepM ((TypeRepTodo
-> KindRepM [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))])
-> [TypeRepTodo]
-> KindRepM [[Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]]
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 GhcTc]
TypeRepTodo
-> KindRepM [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
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 GhcTc] -> TcGblEnv
`addTypecheckedBinds` [[Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]]
-> [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]]
binds }
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 {
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 GhcTc GhcTc)
ghc_prim_module_bind <- IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind IdP GhcTc
Var
ghc_prim_module_id
(GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Module -> TcM (LHsExpr GhcTc)
mkModIdRHS Module
gHC_PRIM
; 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 GhcTc] -> TcGblEnv
`addTypecheckedBinds`
[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
ghc_prim_module_bind]
; TypeRepTodo
todo1 <- [(Type, Name)] -> TcM TypeRepTodo
todoForExportedKindReps [(Type, Name)]
builtInKindReps
; 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
Just Var
mod_id -> Var
mod_id
Maybe Var
Nothing -> String -> SDoc -> Var
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcMkTypeableBinds" SDoc
forall doc. IsOutput doc => doc
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, [])
}
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
]
ghcTypesTypeableTyCons :: [TyCon]
ghcTypesTypeableTyCons :: [TyCon]
ghcTypesTypeableTyCons = [ TyCon
runtimeRepTyCon, TyCon
levityTyCon
, TyCon
vecCountTyCon, TyCon
vecElemTyCon ]
data TypeableStuff
= Stuff { TypeableStuff -> Platform
platform :: Platform
, TypeableStuff -> DataCon
trTyConDataCon :: DataCon
, TypeableStuff -> FastString -> LHsExpr GhcTc
trNameLit :: FastString -> LHsExpr GhcTc
, 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_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 GhcTc)
trNameLit <- TcM (FastString -> LHsExpr GhcTc)
IOEnv
(Env TcGblEnv TcLclEnv)
(FastString -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
mkTrNameLit
TypeableStuff -> TcM TypeableStuff
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Stuff {TyCon
DataCon
Platform
FastString -> LHsExpr GhcTc
FastString -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
platform :: Platform
trTyConDataCon :: DataCon
trNameLit :: FastString -> LHsExpr GhcTc
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 GhcTc)
..}
mkTrNameLit :: TcM (FastString -> LHsExpr GhcTc)
mkTrNameLit :: TcM (FastString -> LHsExpr GhcTc)
mkTrNameLit = do
DataCon
trNameSDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
trNameSDataConName
let trNameLit :: FastString -> LHsExpr GhcTc
trNameLit :: FastString -> LHsExpr GhcTc
trNameLit FastString
fs = LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr GhcTc -> LHsExpr GhcTc) -> LHsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
trNameSDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit GhcTc -> LHsExpr GhcTc
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (FastString -> HsLit GhcTc
forall (p :: Pass). FastString -> HsLit (GhcPass p)
mkHsStringPrimLit FastString
fs)
(FastString -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(FastString -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return FastString -> LHsExpr GhcTc
FastString -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
trNameLit
mkTyConRepBinds :: TypeableStuff -> TypeRepTodo
-> TypeableTyCon -> KindRepM (LHsBinds GhcTc)
mkTyConRepBinds :: TypeableStuff
-> TypeRepTodo -> TypeableTyCon -> KindRepM (LHsBinds GhcTc)
mkTyConRepBinds TypeableStuff
stuff TypeRepTodo
todo (TypeableTyCon {Var
TyCon
tycon :: TypeableTyCon -> TyCon
tycon_rep_id :: TypeableTyCon -> Var
tycon :: TyCon
tycon_rep_id :: Var
..})
= do
let ([ForAllTyBinder]
bndrs, Type
kind) = Type -> ([ForAllTyBinder], Type)
splitForAllForAllTyBinders (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
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Type
tyConKind TyCon
tycon) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
kind)
let ctx :: CmEnv
ctx = [Var] -> CmEnv
mkDeBruijnContext ((ForAllTyBinder -> Var) -> [ForAllTyBinder] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map ForAllTyBinder -> Var
forall tv argf. VarBndr tv argf -> tv
binderVar [ForAllTyBinder]
bndrs)
GenLocated SrcSpanAnnA (HsExpr GhcTc)
kind_rep <- TypeableStuff -> CmEnv -> Type -> KindRepM (LHsExpr GhcTc)
getKindRep TypeableStuff
stuff CmEnv
ctx Type
kind
let tycon_rep_rhs :: LHsExpr GhcTc
tycon_rep_rhs = TypeableStuff
-> TypeRepTodo -> TyCon -> LHsExpr GhcTc -> LHsExpr GhcTc
mkTyConRepTyConRHS TypeableStuff
stuff TypeRepTodo
todo TyCon
tycon LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
kind_rep
tycon_rep_bind :: LHsBind GhcTc
tycon_rep_bind = IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind IdP GhcTc
Var
tycon_rep_id LHsExpr GhcTc
tycon_rep_rhs
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> KindRepM (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> KindRepM (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> KindRepM (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag LHsBind GhcTc
GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
tycon_rep_bind
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)
kindIsTypeable :: Kind -> Bool
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 FunTyFlag
_ 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
kindIsTypeable (CoercionTy{}) = Bool
False
type KindRepEnv = TypeMap (Id, Maybe (LHsExpr GhcTc))
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 GhcTc))))
TcRn
a
-> KindRepM a
forall a. StateT KindRepEnv TcRn a -> KindRepM a
KindRepM (StateT
(TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
TcRn
a
-> KindRepM a)
-> (TcRn a
-> StateT
(TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
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 GhcTc))))
TcRn
a
forall (m :: * -> *) a.
Monad m =>
m a
-> StateT
(TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
builtInKindReps :: [(Kind, Name)]
builtInKindReps :: [(Type, Name)]
builtInKindReps =
[ (Type
star, Name
starKindRepName)
, (Type
constraintKind, Name
constraintKindRepName)
, ((() :: Constraint) => Type -> Type -> Type
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 GhcTc)))
-> (Type, Name)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
-> TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> [(Type, Name)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
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 GhcTc)))
-> (Type, Name)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
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 GhcTc)))
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)
mkExportedKindReps :: TypeableStuff
-> [(Kind, Id)]
-> 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
GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs <- TypeableStuff -> CmEnv -> Type -> KindRepM (LHsExpr GhcTc)
mkKindRepRhs TypeableStuff
stuff CmEnv
empty_scope Type
kind
TcRn () -> KindRepM ()
forall a. TcRn a -> KindRepM a
liftTc (String -> SDoc -> TcRn ()
traceTc String
"mkExport" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
kind SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
rep_bndr SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ GenLocated SrcSpanAnnA (HsExpr GhcTc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs))
CmEnv -> Type -> Var -> LHsExpr GhcTc -> KindRepM ()
addKindRepBind CmEnv
empty_scope Type
kind Var
rep_bndr LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs
addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr GhcTc -> KindRepM ()
addKindRepBind :: CmEnv -> Type -> Var -> LHsExpr GhcTc -> KindRepM ()
addKindRepBind CmEnv
in_scope Type
k Var
bndr LHsExpr GhcTc
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 GhcTc)))
-> CmEnv
-> Type
-> (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. TypeMap a -> CmEnv -> Type -> a -> TypeMap a
extendTypeMapWithScope KindRepEnv
TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
env CmEnv
in_scope Type
k (Var
bndr, GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> Maybe a
Just LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs)
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 GhcTc)))
kindRepEnv <- TcRn KindRepEnv
IOEnv
(Env TcGblEnv TcLclEnv)
(TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
initialKindRepEnv
(a
res, TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
reps_env) <- StateT
(TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
TcRn
a
-> TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(a, TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT KindRepEnv TcRn a
StateT
(TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
TcRn
a
action TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
kindRepEnv
let rep_binds :: [(Var, GenLocated SrcSpanAnnA (HsExpr GhcTc))]
rep_binds = ((Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> [(Var, GenLocated SrcSpanAnnA (HsExpr GhcTc))]
-> [(Var, GenLocated SrcSpanAnnA (HsExpr GhcTc))])
-> [(Var, GenLocated SrcSpanAnnA (HsExpr GhcTc))]
-> TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> [(Var, GenLocated SrcSpanAnnA (HsExpr GhcTc))]
forall a b. (a -> b -> b) -> b -> TypeMap a -> b
foldTypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> [(Var, GenLocated SrcSpanAnnA (HsExpr GhcTc))]
-> [(Var, GenLocated SrcSpanAnnA (HsExpr GhcTc))]
forall {a} {b}. (a, Maybe b) -> [(a, b)] -> [(a, b)]
to_bind_pair [] TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
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 GhcTc)) -> Var)
-> [(Var, GenLocated SrcSpanAnnA (HsExpr GhcTc))] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, GenLocated SrcSpanAnnA (HsExpr GhcTc)) -> Var
forall a b. (a, b) -> a
fst [(Var, GenLocated SrcSpanAnnA (HsExpr GhcTc))]
rep_binds) TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
let binds :: [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
binds = ((Var, GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> [(Var, GenLocated SrcSpanAnnA (HsExpr GhcTc))]
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map ((Var
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> (Var, GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc
Var
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind) [(Var, GenLocated SrcSpanAnnA (HsExpr GhcTc))]
rep_binds
tcg_env' :: TcGblEnv
tcg_env' = TcGblEnv
tcg_env TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
`addTypecheckedBinds` [[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. [a] -> Bag a
listToBag [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
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)
getKindRep :: TypeableStuff -> CmEnv
-> Kind
-> KindRepM (LHsExpr GhcTc)
getKindRep :: TypeableStuff -> CmEnv -> Type -> KindRepM (LHsExpr GhcTc)
getKindRep stuff :: TypeableStuff
stuff@(Stuff {TyCon
DataCon
Platform
FastString -> LHsExpr GhcTc
platform :: TypeableStuff -> Platform
trTyConDataCon :: TypeableStuff -> DataCon
trNameLit :: TypeableStuff -> FastString -> LHsExpr GhcTc
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 GhcTc
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 GhcTc)
go
where
go :: Kind -> KindRepM (LHsExpr GhcTc)
go :: Type -> KindRepM (LHsExpr GhcTc)
go = StateT KindRepEnv TcRn (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
StateT
(TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
TcRn
(GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. StateT KindRepEnv TcRn a -> KindRepM a
KindRepM (StateT
(TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
TcRn
(GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> (Type
-> StateT
(TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
TcRn
(GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> Type
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc),
TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
-> StateT
(TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
TcRn
(GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc),
TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
-> StateT
(TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
TcRn
(GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> (Type
-> TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc),
TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
-> Type
-> StateT
(TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
TcRn
(GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv)
Type
-> TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc),
TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
go'
go' :: Kind -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv)
go' :: Type -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv)
go' Type
k KindRepEnv
env
| Just (Var
id, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))
_) <- TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> CmEnv
-> Type
-> Maybe (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. TypeMap a -> CmEnv -> Type -> Maybe a
lookupTypeMapWithScope KindRepEnv
TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
env CmEnv
in_scope Type
k
= (GenLocated SrcSpanAnnA (HsExpr GhcTc),
TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc),
TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IdP GhcTc -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcTc
Var
id, KindRepEnv
TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
env)
| Bool
otherwise
= do
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
ManyTy (TyCon -> Type
mkTyConTy TyCon
kindRepTyCon)
(StateT
(TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
TcRn
(GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc),
TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
-> TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> StateT
(TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
TcRn
(GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc),
TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
(TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
TcRn
(GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc),
TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT KindRepEnv
TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
env (StateT
(TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
TcRn
(GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc),
TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
-> StateT
(TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
TcRn
(GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcTc),
TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a b. (a -> b) -> a -> b
$ KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> StateT KindRepEnv TcRn (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. KindRepM a -> StateT KindRepEnv TcRn a
unKindRepM (KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> StateT KindRepEnv TcRn (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> StateT KindRepEnv TcRn (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ do
GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs <- TypeableStuff -> CmEnv -> Type -> KindRepM (LHsExpr GhcTc)
mkKindRepRhs TypeableStuff
stuff CmEnv
in_scope Type
k
CmEnv -> Type -> Var -> LHsExpr GhcTc -> KindRepM ()
addKindRepBind CmEnv
in_scope Type
k Var
rep_bndr LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs
GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ IdP GhcTc -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcTc
Var
rep_bndr
mkKindRepRhs :: TypeableStuff
-> CmEnv
-> Kind
-> KindRepM (LHsExpr GhcTc)
mkKindRepRhs :: TypeableStuff -> CmEnv -> Type -> KindRepM (LHsExpr GhcTc)
mkKindRepRhs stuff :: TypeableStuff
stuff@(Stuff {TyCon
DataCon
Platform
FastString -> LHsExpr GhcTc
platform :: TypeableStuff -> Platform
trTyConDataCon :: TypeableStuff -> DataCon
trNameLit :: TypeableStuff -> FastString -> LHsExpr GhcTc
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 GhcTc
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 GhcTc)
Type -> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
new_kind_rep_shortcut
where
new_kind_rep_shortcut :: Type -> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
new_kind_rep_shortcut Type
k
| Just (TypeOrConstraint
TypeLike, Type
rep) <- Type -> Maybe (TypeOrConstraint, Type)
sORTKind_maybe Type
k
=
case (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
rep of
Just (TyCon
tc, [])
| Just DataCon
dc <- TyCon -> Maybe DataCon
isPromotedDataCon_maybe TyCon
tc
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
kindRepTYPEDataCon LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
dc
Just (TyCon
rep_tc, [Type
levArg])
| Just DataCon
dcRep <- TyCon -> Maybe DataCon
isPromotedDataCon_maybe TyCon
rep_tc
, Just (TyCon
lev_tc, []) <- (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
levArg
, Just DataCon
dcLev <- TyCon -> Maybe DataCon
isPromotedDataCon_maybe TyCon
lev_tc
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
kindRepTYPEDataCon LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` (DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
dcRep LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
dcLev)
Maybe (TyCon, [Type])
_ -> Type -> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
new_kind_rep Type
k
| Bool
otherwise = Type -> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
new_kind_rep Type
k
new_kind_rep :: Type -> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
new_kind_rep Type
ki
| Just Type
ki' <- Type -> Maybe Type
coreView Type
ki
= Type -> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
new_kind_rep Type
ki'
new_kind_rep (TyVarTy Var
v)
| Just Int
idx <- CmEnv -> Var -> Maybe Int
lookupCME CmEnv
in_scope Var
v
= GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
kindRepVarDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` Integer -> LHsExpr GhcTc
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 GhcTc))
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 GhcTc)
rep1 <- TypeableStuff -> CmEnv -> Type -> KindRepM (LHsExpr GhcTc)
getKindRep TypeableStuff
stuff CmEnv
in_scope Type
t1
GenLocated SrcSpanAnnA (HsExpr GhcTc)
rep2 <- TypeableStuff -> CmEnv -> Type -> KindRepM (LHsExpr GhcTc)
getKindRep TypeableStuff
stuff CmEnv
in_scope Type
t2
GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
kindRepAppDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
rep1 LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
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 GhcTc)]
tys' <- (Type -> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> [Type] -> KindRepM [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
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 GhcTc)
getKindRep TypeableStuff
stuff CmEnv
in_scope) [Type]
tys
GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
kindRepTyConAppDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` IdP GhcTc -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcTc
Var
rep_id
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` Type -> [LHsExpr GhcTc] -> LHsExpr GhcTc
mkList (TyCon -> Type
mkTyConTy TyCon
kindRepTyCon) [LHsExpr GhcTc]
[GenLocated SrcSpanAnnA (HsExpr GhcTc)]
tys'
| Bool
otherwise
= String -> SDoc -> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTyConKindRepBinds(TyConApp)" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
k)
new_kind_rep (ForAllTy (Bndr Var
var ForAllTyFlag
_) Type
ty)
= String -> SDoc -> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTyConKindRepBinds(ForAllTy)" (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
var SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
new_kind_rep (FunTy FunTyFlag
_ Type
_ Type
t1 Type
t2)
= do GenLocated SrcSpanAnnA (HsExpr GhcTc)
rep1 <- TypeableStuff -> CmEnv -> Type -> KindRepM (LHsExpr GhcTc)
getKindRep TypeableStuff
stuff CmEnv
in_scope Type
t1
GenLocated SrcSpanAnnA (HsExpr GhcTc)
rep2 <- TypeableStuff -> CmEnv -> Type -> KindRepM (LHsExpr GhcTc)
getKindRep TypeableStuff
stuff CmEnv
in_scope Type
t2
GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
kindRepFunDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
rep1 LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
rep2
new_kind_rep (LitTy (NumTyLit Integer
n))
= GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
kindRepTypeLitSDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
typeLitNatDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit GhcTc -> LHsExpr GhcTc
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (FastString -> HsLit GhcTc
forall (p :: Pass). FastString -> HsLit (GhcPass p)
mkHsStringPrimLit (FastString -> HsLit GhcTc) -> FastString -> HsLit GhcTc
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 GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
kindRepTypeLitSDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
typeLitSymbolDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit GhcTc -> LHsExpr GhcTc
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (FastString -> HsLit GhcTc
forall (p :: Pass). FastString -> HsLit (GhcPass p)
mkHsStringPrimLit (FastString -> HsLit GhcTc) -> FastString -> HsLit GhcTc
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 GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
kindRepTypeLitSDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
typeLitCharDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit GhcTc -> LHsExpr GhcTc
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (Char -> HsLit GhcTc
forall (p :: Pass). Char -> HsLit (GhcPass p)
mkHsCharPrimLit Char
c)
new_kind_rep (CastTy Type
ty KindCoercion
co)
= String -> SDoc -> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
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
forall doc. IsDoc doc => doc -> doc -> doc
$$ KindCoercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr KindCoercion
co)
new_kind_rep (CoercionTy KindCoercion
co)
= String -> SDoc -> KindRepM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTyConKindRepBinds.go(coercion)" (KindCoercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr KindCoercion
co)
mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo
-> TyCon
-> LHsExpr GhcTc
-> LHsExpr GhcTc
mkTyConRepTyConRHS :: TypeableStuff
-> TypeRepTodo -> TyCon -> LHsExpr GhcTc -> LHsExpr GhcTc
mkTyConRepTyConRHS (Stuff {TyCon
DataCon
Platform
FastString -> LHsExpr GhcTc
platform :: TypeableStuff -> Platform
trTyConDataCon :: TypeableStuff -> DataCon
trNameLit :: TypeableStuff -> FastString -> LHsExpr GhcTc
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 GhcTc
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 GhcTc
kind_rep
= DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
trTyConDataCon
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit GhcTc -> LHsExpr GhcTc
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (XHsWord64Prim GhcTc -> Integer -> HsLit GhcTc
forall x. XHsWord64Prim x -> Integer -> HsLit x
HsWord64Prim XHsWord64Prim GhcTc
SourceText
NoSourceText (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
high))
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit GhcTc -> LHsExpr GhcTc
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (XHsWord64Prim GhcTc -> Integer -> HsLit GhcTc
forall x. XHsWord64Prim x -> Integer -> HsLit x
HsWord64Prim XHsWord64Prim GhcTc
SourceText
NoSourceText (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
low))
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` TypeRepTodo -> LHsExpr GhcTc
mod_rep_expr TypeRepTodo
todo
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` FastString -> LHsExpr GhcTc
trNameLit (String -> FastString
mkFastString String
tycon_str)
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit GhcTc -> LHsExpr GhcTc
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (XHsIntPrim GhcTc -> Integer -> HsLit GhcTc
forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim XHsIntPrim GhcTc
SourceText
NoSourceText (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n_kind_vars))
LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr GhcTc
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
isDataKindsPromotedDataCon TyCon
tycon = Char
'\'' Char -> String -> String
forall a. a -> [a] -> [a]
: String
s
| Bool
otherwise = String
s
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
]
mkList :: Type -> [LHsExpr GhcTc] -> LHsExpr GhcTc
mkList :: Type -> [LHsExpr GhcTc] -> LHsExpr GhcTc
mkList Type
ty = (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
consApp (Type -> LHsExpr GhcTc
nilExpr Type
ty)
where
cons :: LHsExpr GhcTc
cons = Type -> LHsExpr GhcTc
consExpr Type
ty
consApp :: LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
consApp :: LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
consApp LHsExpr GhcTc
x LHsExpr GhcTc
xs = LHsExpr GhcTc
cons LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr GhcTc
x LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr GhcTc
xs
nilExpr :: Type -> LHsExpr GhcTc
nilExpr :: Type -> LHsExpr GhcTc
nilExpr Type
ty = HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap ([Type] -> HsWrapper
mkWpTyApps [Type
ty]) (DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
nilDataCon)
consExpr :: Type -> LHsExpr GhcTc
consExpr :: Type -> LHsExpr GhcTc
consExpr Type
ty = HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap ([Type] -> HsWrapper
mkWpTyApps [Type
ty]) (DataCon -> LHsExpr GhcTc
nlHsDataCon DataCon
consDataCon)