{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.Tc.Instance.Typeable(mkTypeableBinds, tyConIsTypeable) where
import GHC.Prelude
import GHC.Platform
import GHC.Types.Basic ( 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
( 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.DynFlags
import GHC.Types.Var ( VarBndr(..) )
import GHC.Core.Map.Type
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 { dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; if gopt Opt_NoTypeableBinds dflags then getGblEnv else do
{
; tcg_env <- mkModIdBindings
; (tcg_env, prim_todos) <- setGblEnv tcg_env mkPrimTypeableTodos
; setGblEnv tcg_env $
do { mod <- getModule
; let 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 = 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)
; traceTc "mkTypeableBinds" (ppr tycons)
; this_mod_todos <- todoForTyCons mod mod_id tycons
; mkTypeRepTodoBinds (this_mod_todos : 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 { mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; loc <- getSrcSpanM
; mod_nm <- newGlobalBinder mod (mkVarOccFS (fsLit "$trModule")) loc
; trModuleTyCon <- tcLookupTyCon trModuleTyConName
; let mod_id = Name -> Type -> Var
mkExportedVanillaId Name
mod_nm (TyCon -> [Type] -> Type
mkTyConApp TyCon
trModuleTyCon [])
; mod_bind <- mkVarBind mod_id <$> mkModIdRHS mod
; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv
; return (tcg_env { tcg_tr_module = Just mod_id }
`addTypecheckedBinds` [[mod_bind]]) }
mkModIdRHS :: Module -> TcM (LHsExpr GhcTc)
mkModIdRHS :: Module -> TcM (LHsExpr GhcTc)
mkModIdRHS Module
mod
= do { trModuleDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
trModuleDataConName
; trNameLit <- mkTrNameLit
; return $ nlHsDataCon trModuleDataCon
`nlHsApp` trNameLit (unitFS (moduleUnit mod))
`nlHsApp` trNameLit (moduleNameFS (moduleName mod))
}
data TypeableTyCon
= TypeableTyCon
{ TypeableTyCon -> TyCon
tycon :: !TyCon
, TypeableTyCon -> Var
tycon_rep_id :: !Id
}
data TypeRepTodo
= TyConTodo TyConTodo
| ExportedKindRepsTodo [(Kind, Id)]
data TyConTodo
= TCTD { TyConTodo -> LHsExpr GhcTc
mod_rep_expr :: LHsExpr GhcTc
, TyConTodo -> Fingerprint
pkg_fingerprint :: !Fingerprint
, TyConTodo -> Fingerprint
mod_fingerprint :: !Fingerprint
, TyConTodo -> [TypeableTyCon]
todo_tycons :: [TypeableTyCon]
}
todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo
todoForTyCons :: Module -> Var -> [TyCon] -> TcM TypeRepTodo
todoForTyCons Module
mod Var
mod_id [TyCon]
tycons = do
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
rep_name = Name -> Type -> Var
mkExportedVanillaId Name
rep_name Type
trTyConTy
let 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''
]
return $ TyConTodo $
TCTD { mod_rep_expr = nlHsVar mod_id
, pkg_fingerprint = pkg_fpr
, mod_fingerprint = mod_fpr
, todo_tycons = 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
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
k, Name
name) = (Type
k, Name -> Type -> Var
mkExportedVanillaId Name
name Type
trKindRepTy)
return $ ExportedKindRepsTodo $ map mkId kinds
mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv
mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv
mkTypeRepTodoBinds [] = TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
mkTypeRepTodoBinds [TypeRepTodo]
todos
= do { stuff <- TcM TypeableStuff
collect_stuff
; let produced_bndrs :: [Id]
produced_bndrs = [ Var
tycon_rep_id
| TyConTodo (TCTD { todo_tycons :: TyConTodo -> [TypeableTyCon]
todo_tycons = [TypeableTyCon]
tcs }) <- [TypeRepTodo]
todos
, TypeableTyCon {Var
TyCon
tycon :: TypeableTyCon -> TyCon
tycon_rep_id :: TypeableTyCon -> Var
tycon_rep_id :: Var
tycon :: TyCon
..} <- [TypeableTyCon]
tcs
] [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++
[ Var
rep_id
| ExportedKindRepsTodo [(Type, Var)]
kinds <- [TypeRepTodo]
todos
, (Type
_, Var
rep_id) <- [(Type, Var)]
kinds
]
; gbl_env <- tcExtendGlobalValEnv produced_bndrs getGblEnv
; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds GhcTc]
mk_binds (TyConTodo (todo :: TyConTodo
todo@(TCTD { todo_tycons :: TyConTodo -> [TypeableTyCon]
todo_tycons = [TypeableTyCon]
tcs }))) =
(TypeableTyCon
-> KindRepM [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])
-> [TypeableTyCon]
-> KindRepM [[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
-> TyConTodo -> TypeableTyCon -> KindRepM (LHsBinds GhcTc)
mkTyConRepBinds TypeableStuff
stuff TyConTodo
todo) [TypeableTyCon]
tcs
mk_binds (ExportedKindRepsTodo [(Type, Var)]
kinds) =
TypeableStuff -> [(Type, Var)] -> KindRepM ()
mkExportedKindReps TypeableStuff
stuff [(Type, Var)]
kinds KindRepM ()
-> KindRepM [[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]]
-> KindRepM [[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
>> [[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]]
-> KindRepM [[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]]
forall a. a -> KindRepM a
forall (m :: * -> *) a. Monad m => a -> m a
return []
; (gbl_env, binds) <- setGblEnv gbl_env
$ runKindRepM (mapM mk_binds todos)
; return $ gbl_env `addTypecheckedBinds` concat binds }
mkPrimTypeableTodos :: TcM (TcGblEnv, [TypeRepTodo])
mkPrimTypeableTodos :: TcRnIf TcGblEnv TcLclEnv (TcGblEnv, [TypeRepTodo])
mkPrimTypeableTodos
= do { mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; if mod == gHC_TYPES
then do {
trModuleTyCon <- tcLookupTyCon trModuleTyConName
; let ghc_prim_module_id =
Name -> Type -> Var
mkExportedVanillaId Name
trGhcPrimModuleName
(TyCon -> Type
mkTyConTy TyCon
trModuleTyCon)
; ghc_prim_module_bind <- mkVarBind ghc_prim_module_id
<$> mkModIdRHS gHC_PRIM
; gbl_env <- tcExtendGlobalValEnv [ghc_prim_module_id]
getGblEnv
; let gbl_env' = TcGblEnv
gbl_env TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
`addTypecheckedBinds`
[[LHsBind GhcTc
GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
ghc_prim_module_bind]]
; todo1 <- todoForExportedKindReps builtInKindReps
; todo2 <- todoForTyCons gHC_PRIM ghc_prim_module_id
ghcPrimTypeableTyCons
; tcg_env <- getGblEnv
; let 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
; todo3 <- todoForTyCons gHC_TYPES mod_id ghcTypesTypeableTyCons
; return ( gbl_env' , [todo1, todo2, todo3])
}
else do gbl_env <- getGblEnv
return (gbl_env, [])
}
ghcPrimTypeableTyCons :: [TyCon]
ghcPrimTypeableTyCons :: [TyCon]
ghcPrimTypeableTyCons = [[TyCon]] -> [TyCon]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [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 <- 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
trTyConDataCon <- tcLookupDataCon trTyConDataConName
kindRepTyCon <- tcLookupTyCon kindRepTyConName
kindRepTyConAppDataCon <- tcLookupDataCon kindRepTyConAppDataConName
kindRepVarDataCon <- tcLookupDataCon kindRepVarDataConName
kindRepAppDataCon <- tcLookupDataCon kindRepAppDataConName
kindRepFunDataCon <- tcLookupDataCon kindRepFunDataConName
kindRepTYPEDataCon <- tcLookupDataCon kindRepTYPEDataConName
kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName
typeLitSymbolDataCon <- tcLookupDataCon typeLitSymbolDataConName
typeLitNatDataCon <- tcLookupDataCon typeLitNatDataConName
typeLitCharDataCon <- tcLookupDataCon typeLitCharDataConName
trNameLit <- mkTrNameLit
return Stuff {..}
mkTrNameLit :: TcM (FastString -> LHsExpr GhcTc)
mkTrNameLit :: TcM (FastString -> LHsExpr GhcTc)
mkTrNameLit = do
trNameSDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
trNameSDataConName
let trNameLit :: FastString -> LHsExpr GhcTc
trNameLit FastString
fs = LHsExpr GhcTc -> LHsExpr GhcTc
forall (p :: Pass).
IsPass p =>
LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
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)
return trNameLit
mkTyConRepBinds :: TypeableStuff -> TyConTodo
-> TypeableTyCon -> KindRepM (LHsBinds GhcTc)
mkTyConRepBinds :: TypeableStuff
-> TyConTodo -> TypeableTyCon -> KindRepM (LHsBinds GhcTc)
mkTyConRepBinds TypeableStuff
stuff TyConTodo
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)
kind_rep <- TypeableStuff -> CmEnv -> Type -> KindRepM (LHsExpr GhcTc)
getKindRep TypeableStuff
stuff CmEnv
ctx Type
kind
let tycon_rep_rhs = TypeableStuff
-> TyConTodo -> TyCon -> LHsExpr GhcTc -> LHsExpr GhcTc
mkTyConRepTyConRHS TypeableStuff
stuff TyConTodo
todo TyCon
tycon LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
kind_rep
tycon_rep_bind = IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc
mkVarBind IdP GhcTc
Var
tycon_rep_id LHsExpr GhcTc
tycon_rep_rhs
return [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)
, (HasDebugCallStack => 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
id <- Name -> TcM Var
tcLookupId Name
n
return $! extendTypeMap acc k (id, 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
rhs <- TypeableStuff -> CmEnv -> Type -> KindRepM (LHsExpr GhcTc)
mkKindRepRhs TypeableStuff
stuff CmEnv
empty_scope Type
kind
liftTc (traceTc "mkExport" (ppr kind $$ ppr rep_bndr $$ ppr rhs))
addKindRepBind empty_scope kind rep_bndr 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
kindRepEnv <- TcRn KindRepEnv
IOEnv
(Env TcGblEnv TcLclEnv)
(TypeMap (Var, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
initialKindRepEnv
(res, reps_env) <- runStateT action kindRepEnv
let 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
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
tcg_env <- tcExtendGlobalValEnv (map fst rep_binds) getGblEnv
let 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)
mkVarBind) [(Var, GenLocated SrcSpanAnnA (HsExpr GhcTc))]
rep_binds
tcg_env' = TcGblEnv
tcg_env TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
`addTypecheckedBinds` [LHsBinds GhcTc
[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
binds]
return (tcg_env', 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
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)
flip runStateT env $ unKindRepM $ do
rhs <- mkKindRepRhs stuff in_scope k
addKindRepBind in_scope k rep_bndr rhs
return $ nlHsVar 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 HasDebugCallStack => 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, []) <- HasDebugCallStack => 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 rep1 <- TypeableStuff -> CmEnv -> Type -> KindRepM (LHsExpr GhcTc)
getKindRep TypeableStuff
stuff CmEnv
in_scope Type
t1
rep2 <- getKindRep stuff in_scope t2
return $ nlHsDataCon kindRepAppDataCon
`nlHsApp` rep1 `nlHsApp` rep2
new_kind_rep k :: Type
k@(TyConApp TyCon
tc [Type]
tys)
| Just Name
rep_name <- TyCon -> Maybe Name
tyConRepName_maybe TyCon
tc
= do 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
tys' <- mapM (getKindRep stuff in_scope) tys
return $ nlHsDataCon kindRepTyConAppDataCon
`nlHsApp` nlHsVar rep_id
`nlHsApp` mkList (mkTyConTy kindRepTyCon) 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 rep1 <- TypeableStuff -> CmEnv -> Type -> KindRepM (LHsExpr GhcTc)
getKindRep TypeableStuff
stuff CmEnv
in_scope Type
t1
rep2 <- getKindRep stuff in_scope t2
return $ nlHsDataCon kindRepFunDataCon
`nlHsApp` rep1 `nlHsApp` 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 -> TyConTodo
-> TyCon
-> LHsExpr GhcTc
-> LHsExpr GhcTc
mkTyConRepTyConRHS :: TypeableStuff
-> TyConTodo -> 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
..}) TyConTodo
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` TyConTodo -> LHsExpr GhcTc
mod_rep_expr TyConTodo
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 [ TyConTodo -> Fingerprint
pkg_fingerprint TyConTodo
todo
, TyConTodo -> Fingerprint
mod_fingerprint TyConTodo
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)