{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.Tc.Instance.Typeable(mkTypeableBinds, tyConIsTypeable) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Platform
import GHC.Types.Basic ( Boxity(..), neverInlinePragma )
import GHC.Types.SourceText ( SourceText(..) )
import GHC.Iface.Env( newGlobalBinder )
import GHC.Core.TyCo.Rep( Type(..), TyLit(..) )
import GHC.Tc.Utils.Env
import GHC.Tc.Types.Evidence ( mkWpTyApps )
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcType
import GHC.Types.TyThing ( lookupId )
import GHC.Builtin.Names
import GHC.Builtin.Types.Prim ( primTyCons )
import GHC.Builtin.Types
( tupleTyCon, sumTyCon, runtimeRepTyCon
, levityTyCon, vecCountTyCon, vecElemTyCon
, nilDataCon, consDataCon )
import GHC.Types.Name
import GHC.Types.Id
import GHC.Core.Type
import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Unit.Module
import GHC.Hs
import GHC.Driver.Session
import GHC.Data.Bag
import GHC.Types.Var ( VarBndr(..) )
import GHC.Core.Map.Type
import GHC.Settings.Constants
import GHC.Utils.Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints)
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString ( FastString, mkFastString, fsLit )
import Control.Monad.Trans.State
import Control.Monad.Trans.Class (lift)
import Data.Maybe ( isJust )
import Data.Word( Word64 )
mkTypeableBinds :: TcM TcGblEnv
mkTypeableBinds :: TcM TcGblEnv
mkTypeableBinds
= do { DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NoTypeableBinds DynFlags
dflags then forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv else do
{
; TcGblEnv
tcg_env <- TcM TcGblEnv
mkModIdBindings
; (TcGblEnv
tcg_env, [TypeRepTodo]
prim_todos) <- forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env TcM (TcGblEnv, [TypeRepTodo])
mkPrimTypeableTodos
; forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env forall a b. (a -> b) -> a -> b
$
do { Module
mod <- forall (m :: * -> *). HasModule m => m Module
getModule
; let tycons :: [TyCon]
tycons = 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 -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcMkTypeableBinds" (forall a. Outputable a => a -> SDoc
ppr [TyCon]
tycons)
; String -> SDoc -> TcRn ()
traceTc String
"mkTypeableBinds" (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 forall a. a -> [a] -> [a]
: [TypeRepTodo]
prim_todos)
} } }
where
needs_typeable_binds :: TyCon -> Bool
needs_typeable_binds TyCon
tc
| TyCon
tc forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TyCon
runtimeRepTyCon, TyCon
levityTyCon, TyCon
vecCountTyCon, TyCon
vecElemTyCon]
= 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 <- forall (m :: * -> *). HasModule m => m Module
getModule
; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; Name
mod_nm <- forall a b. Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder Module
mod (String -> OccName
mkVarOcc String
"$trModule") SrcSpan
loc
; TyCon
trModuleTyCon <- Name -> TcM TyCon
tcLookupTyCon Name
trModuleTyConName
; let mod_id :: Var
mod_id = Name -> Type -> Var
mkExportedVanillaId Name
mod_nm (TyCon -> [Type] -> Type
mkTyConApp TyCon
trModuleTyCon [])
; GenLocated
SrcSpanAnnA
(HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
mod_bind <- forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind Var
mod_id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Module -> TcM (LHsExpr (GhcPass 'Typechecked))
mkModIdRHS Module
mod
; TcGblEnv
tcg_env <- forall a. [Var] -> TcM a -> TcM a
tcExtendGlobalValEnv [Var
mod_id] forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env { tcg_tr_module :: Maybe Var
tcg_tr_module = forall a. a -> Maybe a
Just Var
mod_id }
TcGblEnv -> [LHsBinds (GhcPass 'Typechecked)] -> TcGblEnv
`addTypecheckedBinds` [forall a. a -> Bag a
unitBag GenLocated
SrcSpanAnnA
(HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
mod_bind]) }
mkModIdRHS :: Module -> TcM (LHsExpr GhcTc)
mkModIdRHS :: Module -> TcM (LHsExpr (GhcPass 'Typechecked))
mkModIdRHS Module
mod
= do { DataCon
trModuleDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
trModuleDataConName
; FastString
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
trNameLit <- TcM (FastString -> LHsExpr (GhcPass 'Typechecked))
mkTrNameLit
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
trModuleDataCon
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` FastString
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
trNameLit (forall u. IsUnitId u => u -> FastString
unitFS (forall unit. GenModule unit -> unit
moduleUnit Module
mod))
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` FastString
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
trNameLit (ModuleName -> FastString
moduleNameFS (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 (GhcPass 'Typechecked)
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 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 forall a. a -> [a] -> [a]
: TyCon -> [TyCon]
tyConATs TyCon
tc
, let promoted :: [TyCon]
promoted = forall a b. (a -> b) -> [a] -> [b]
map DataCon -> TyCon
promoteDataCon (TyCon -> [DataCon]
tyConDataCons TyCon
tc')
, TyCon
tc'' <- TyCon
tc' forall a. a -> [a] -> [a]
: [TyCon]
promoted
, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ TyCon -> Bool
isFamInstTyCon TyCon
tc''
, Just Name
rep_name <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TyCon -> Maybe Name
tyConRepName_maybe TyCon
tc''
, TyCon -> Bool
tyConIsTypeable TyCon
tc''
]
forall (m :: * -> *) a. Monad m => a -> m a
return TypeRepTodo { mod_rep_expr :: LHsExpr (GhcPass 'Typechecked)
mod_rep_expr = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar 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 forall a b. (a -> b) -> a -> b
$ ModuleName -> String
moduleNameString forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> ModuleName
moduleName Module
mod
pkg_fpr :: Fingerprint
pkg_fpr = String -> Fingerprint
fingerprintString forall a b. (a -> b) -> a -> b
$ forall u. IsUnitId u => u -> String
unitString forall a b. (a -> b) -> a -> b
$ 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 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)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(Type, Var)] -> TypeRepTodo
ExportedKindRepsTodo forall a b. (a -> b) -> a -> b
$ 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 [] = 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 :: TyCon
tycon_rep_id :: Var
tycon_rep_id :: TypeableTyCon -> Var
tycon :: TypeableTyCon -> TyCon
..} <- TypeRepTodo -> [TypeableTyCon]
todo_tycons TypeRepTodo
todo
] forall a. [a] -> [a] -> [a]
++
[ Var
rep_id
| ExportedKindRepsTodo [(Type, Var)]
kinds <- [TypeRepTodo]
todos
, (Type
_, Var
rep_id) <- [(Type, Var)]
kinds
]
; TcGblEnv
gbl_env <- forall a. [Var] -> TcM a -> TcM a
tcExtendGlobalValEnv [Var]
produced_bndrs forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds GhcTc]
mk_binds :: TypeRepTodo -> KindRepM [LHsBinds (GhcPass 'Typechecked)]
mk_binds todo :: TypeRepTodo
todo@(TypeRepTodo {}) =
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TypeableStuff
-> TypeRepTodo
-> TypeableTyCon
-> KindRepM (LHsBinds (GhcPass 'Typechecked))
mkTyConRepBinds TypeableStuff
stuff TypeRepTodo
todo) (TypeRepTodo -> [TypeableTyCon]
todo_tycons TypeRepTodo
todo)
mk_binds (ExportedKindRepsTodo [(Type, Var)]
kinds) =
TypeableStuff -> [(Type, Var)] -> KindRepM ()
mkExportedKindReps TypeableStuff
stuff [(Type, Var)]
kinds forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return []
; (TcGblEnv
gbl_env, [[Bag
(GenLocated
SrcSpanAnnA
(HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))]]
binds) <- forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
gbl_env
forall a b. (a -> b) -> a -> b
$ forall a. KindRepM a -> TcRn (TcGblEnv, a)
runKindRepM (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypeRepTodo -> KindRepM [LHsBinds (GhcPass 'Typechecked)]
mk_binds [TypeRepTodo]
todos)
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TcGblEnv
gbl_env TcGblEnv -> [LHsBinds (GhcPass 'Typechecked)] -> TcGblEnv
`addTypecheckedBinds` forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Bag
(GenLocated
SrcSpanAnnA
(HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))]]
binds }
mkPrimTypeableTodos :: TcM (TcGblEnv, [TypeRepTodo])
mkPrimTypeableTodos :: TcM (TcGblEnv, [TypeRepTodo])
mkPrimTypeableTodos
= do { Module
mod <- forall (m :: * -> *). HasModule m => m Module
getModule
; if Module
mod 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 (GhcPass 'Typechecked) (GhcPass 'Typechecked))
ghc_prim_module_bind <- forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind Var
ghc_prim_module_id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Module -> TcM (LHsExpr (GhcPass 'Typechecked))
mkModIdRHS Module
gHC_PRIM
; TcGblEnv
gbl_env <- forall a. [Var] -> TcM a -> TcM a
tcExtendGlobalValEnv [Var
ghc_prim_module_id]
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let gbl_env' :: TcGblEnv
gbl_env' = TcGblEnv
gbl_env TcGblEnv -> [LHsBinds (GhcPass 'Typechecked)] -> TcGblEnv
`addTypecheckedBinds`
[forall a. a -> Bag a
unitBag GenLocated
SrcSpanAnnA
(HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
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
; forall (m :: * -> *) a. Monad m => a -> m a
return ( TcGblEnv
gbl_env' , [TypeRepTodo
todo1, TypeRepTodo
todo2])
}
else do TcGblEnv
gbl_env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
gbl_env, [])
}
ghcPrimTypeableTyCons :: [TyCon]
ghcPrimTypeableTyCons :: [TyCon]
ghcPrimTypeableTyCons = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ TyCon
runtimeRepTyCon, TyCon
levityTyCon, TyCon
vecCountTyCon, TyCon
vecElemTyCon ]
, forall a b. (a -> b) -> [a] -> [b]
map (Boxity -> Int -> TyCon
tupleTyCon Boxity
Unboxed) [Int
0..Int
mAX_TUPLE_SIZE]
, forall a b. (a -> b) -> [a] -> [b]
map Int -> TyCon
sumTyCon [Int
2..Int
mAX_SUM_SIZE]
, [TyCon]
primTyCons
]
data TypeableStuff
= Stuff { TypeableStuff -> Platform
platform :: Platform
, TypeableStuff -> DataCon
trTyConDataCon :: DataCon
, TypeableStuff -> FastString -> LHsExpr (GhcPass 'Typechecked)
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
DataCon
trTyConDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
trTyConDataConName
TyCon
kindRepTyCon <- Name -> TcM TyCon
tcLookupTyCon Name
kindRepTyConName
DataCon
kindRepTyConAppDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepTyConAppDataConName
DataCon
kindRepVarDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepVarDataConName
DataCon
kindRepAppDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepAppDataConName
DataCon
kindRepFunDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepFunDataConName
DataCon
kindRepTYPEDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepTYPEDataConName
DataCon
kindRepTypeLitSDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepTypeLitSDataConName
DataCon
typeLitSymbolDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
typeLitSymbolDataConName
DataCon
typeLitNatDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
typeLitNatDataConName
DataCon
typeLitCharDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
typeLitCharDataConName
FastString
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
trNameLit <- TcM (FastString -> LHsExpr (GhcPass 'Typechecked))
mkTrNameLit
forall (m :: * -> *) a. Monad m => a -> m a
return Stuff {Platform
TyCon
DataCon
FastString
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
trNameLit :: FastString
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
typeLitCharDataCon :: DataCon
typeLitNatDataCon :: DataCon
typeLitSymbolDataCon :: DataCon
kindRepTypeLitSDataCon :: DataCon
kindRepTYPEDataCon :: DataCon
kindRepFunDataCon :: DataCon
kindRepAppDataCon :: DataCon
kindRepVarDataCon :: DataCon
kindRepTyConAppDataCon :: DataCon
kindRepTyCon :: TyCon
trTyConDataCon :: DataCon
platform :: Platform
typeLitNatDataCon :: DataCon
typeLitCharDataCon :: DataCon
typeLitSymbolDataCon :: DataCon
kindRepTypeLitSDataCon :: DataCon
kindRepTYPEDataCon :: DataCon
kindRepFunDataCon :: DataCon
kindRepAppDataCon :: DataCon
kindRepVarDataCon :: DataCon
kindRepTyConAppDataCon :: DataCon
kindRepTyCon :: TyCon
trNameLit :: FastString -> LHsExpr (GhcPass 'Typechecked)
trTyConDataCon :: DataCon
platform :: Platform
..}
mkTrNameLit :: TcM (FastString -> LHsExpr GhcTc)
mkTrNameLit :: TcM (FastString -> LHsExpr (GhcPass 'Typechecked))
mkTrNameLit = do
DataCon
trNameSDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
trNameSDataConName
let trNameLit :: FastString -> LHsExpr GhcTc
trNameLit :: FastString -> LHsExpr (GhcPass 'Typechecked)
trNameLit FastString
fs = forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
trNameSDataCon
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (forall (p :: Pass). FastString -> HsLit (GhcPass p)
mkHsStringPrimLit FastString
fs)
forall (m :: * -> *) a. Monad m => a -> m a
return FastString -> LHsExpr (GhcPass 'Typechecked)
trNameLit
mkTyConRepBinds :: TypeableStuff -> TypeRepTodo
-> TypeableTyCon -> KindRepM (LHsBinds GhcTc)
mkTyConRepBinds :: TypeableStuff
-> TypeRepTodo
-> TypeableTyCon
-> KindRepM (LHsBinds (GhcPass 'Typechecked))
mkTyConRepBinds TypeableStuff
stuff TypeRepTodo
todo (TypeableTyCon {Var
TyCon
tycon_rep_id :: Var
tycon :: TyCon
tycon_rep_id :: TypeableTyCon -> Var
tycon :: TypeableTyCon -> TyCon
..})
= do
let ([TyCoVarBinder]
bndrs, Type
kind) = Type -> ([TyCoVarBinder], Type)
splitForAllTyCoVarBinders (TyCon -> Type
tyConKind TyCon
tycon)
forall a. TcRn a -> KindRepM a
liftTc forall a b. (a -> b) -> a -> b
$ String -> SDoc -> TcRn ()
traceTc String
"mkTyConKindRepBinds"
(forall a. Outputable a => a -> SDoc
ppr TyCon
tycon SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr (TyCon -> Type
tyConKind TyCon
tycon) SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Type
kind)
let ctx :: CmEnv
ctx = [Var] -> CmEnv
mkDeBruijnContext (forall a b. (a -> b) -> [a] -> [b]
map forall tv argf. VarBndr tv argf -> tv
binderVar [TyCoVarBinder]
bndrs)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
kind_rep <- TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
getKindRep TypeableStuff
stuff CmEnv
ctx Type
kind
let tycon_rep_rhs :: LHsExpr (GhcPass 'Typechecked)
tycon_rep_rhs = TypeableStuff
-> TypeRepTodo
-> TyCon
-> LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked)
mkTyConRepTyConRHS TypeableStuff
stuff TypeRepTodo
todo TyCon
tycon GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
kind_rep
tycon_rep_bind :: LHsBind (GhcPass 'Typechecked)
tycon_rep_bind = forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind Var
tycon_rep_id LHsExpr (GhcPass 'Typechecked)
tycon_rep_rhs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Bag a
unitBag LHsBind (GhcPass 'Typechecked)
tycon_rep_bind
tyConIsTypeable :: TyCon -> Bool
tyConIsTypeable :: TyCon -> Bool
tyConIsTypeable TyCon
tc =
forall a. Maybe a -> Bool
isJust (TyCon -> Maybe Name
tyConRepName_maybe TyCon
tc)
Bool -> Bool -> Bool
&& Type -> Bool
kindIsTypeable (Type -> Type
dropForAlls 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 AnonArgFlag
_ Type
w Type
a Type
b) = Type -> Bool
kindIsTypeable Type
w Bool -> Bool -> Bool
&&
Type -> Bool
kindIsTypeable Type
a Bool -> Bool -> Bool
&&
Type -> Bool
kindIsTypeable Type
b
kindIsTypeable (TyConApp TyCon
tc [Type]
args) = TyCon -> Bool
tyConIsTypeable TyCon
tc
Bool -> Bool -> Bool
&& 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 -> 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
<$ :: forall a b. a -> KindRepM b -> KindRepM a
$c<$ :: forall a b. a -> KindRepM b -> KindRepM a
fmap :: forall a b. (a -> b) -> KindRepM a -> KindRepM b
$cfmap :: forall a b. (a -> b) -> KindRepM a -> KindRepM b
Functor, Functor 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
<* :: forall a b. KindRepM a -> KindRepM b -> KindRepM a
$c<* :: forall a b. KindRepM a -> KindRepM b -> KindRepM a
*> :: forall a b. KindRepM a -> KindRepM b -> KindRepM b
$c*> :: forall a b. KindRepM a -> KindRepM b -> KindRepM b
liftA2 :: forall a b c.
(a -> b -> c) -> KindRepM a -> KindRepM b -> KindRepM c
$cliftA2 :: forall a b c.
(a -> b -> c) -> KindRepM a -> KindRepM b -> KindRepM c
<*> :: forall a b. KindRepM (a -> b) -> KindRepM a -> KindRepM b
$c<*> :: forall a b. KindRepM (a -> b) -> KindRepM a -> KindRepM b
pure :: forall a. a -> KindRepM a
$cpure :: forall a. a -> KindRepM a
Applicative, Applicative 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
return :: forall a. a -> KindRepM a
$creturn :: forall a. a -> KindRepM a
>> :: forall a b. KindRepM a -> KindRepM b -> KindRepM b
$c>> :: forall a b. KindRepM a -> KindRepM b -> KindRepM b
>>= :: forall a b. KindRepM a -> (a -> KindRepM b) -> KindRepM b
$c>>= :: forall a b. KindRepM a -> (a -> KindRepM b) -> KindRepM b
Monad)
liftTc :: TcRn a -> KindRepM a
liftTc :: forall a. TcRn a -> KindRepM a
liftTc = forall a. StateT KindRepEnv TcRn a -> KindRepM a
KindRepM forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> 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 = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM forall {a}.
TypeMap (Var, Maybe a)
-> (Type, Name)
-> IOEnv (Env TcGblEnv TcLclEnv) (TypeMap (Var, Maybe a))
add_kind_rep 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. TypeMap a -> Type -> a -> TypeMap a
extendTypeMap TypeMap (Var, Maybe a)
acc Type
k (Var
id, forall a. Maybe a
Nothing)
mkExportedKindReps :: TypeableStuff
-> [(Kind, Id)]
-> KindRepM ()
mkExportedKindReps :: TypeableStuff -> [(Type, Var)] -> KindRepM ()
mkExportedKindReps TypeableStuff
stuff = 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 (GhcPass 'Typechecked))
rhs <- TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
mkKindRepRhs TypeableStuff
stuff CmEnv
empty_scope Type
kind
CmEnv
-> Type -> Var -> LHsExpr (GhcPass 'Typechecked) -> KindRepM ()
addKindRepBind CmEnv
empty_scope Type
kind Var
rep_bndr GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rhs
addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr GhcTc -> KindRepM ()
addKindRepBind :: CmEnv
-> Type -> Var -> LHsExpr (GhcPass 'Typechecked) -> KindRepM ()
addKindRepBind CmEnv
in_scope Type
k Var
bndr LHsExpr (GhcPass 'Typechecked)
rhs =
forall a. StateT KindRepEnv TcRn a -> KindRepM a
KindRepM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' forall a b. (a -> b) -> a -> b
$
\KindRepEnv
env -> forall a. TypeMap a -> CmEnv -> Type -> a -> TypeMap a
extendTypeMapWithScope KindRepEnv
env CmEnv
in_scope Type
k (Var
bndr, forall a. a -> Maybe a
Just LHsExpr (GhcPass 'Typechecked)
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 (GhcPass 'Typechecked))))
kindRepEnv <- TcRn KindRepEnv
initialKindRepEnv
(a
res, TypeMap
(Var,
Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
reps_env) <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT KindRepEnv TcRn a
action TypeMap
(Var,
Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
kindRepEnv
let rep_binds :: [(Var, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))]
rep_binds = forall a b. (a -> b -> b) -> b -> TypeMap a -> b
foldTypeMap forall {a} {b}. (a, Maybe b) -> [(a, b)] -> [(a, b)]
to_bind_pair [] TypeMap
(Var,
Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))))
reps_env
to_bind_pair :: (a, Maybe b) -> [(a, b)] -> [(a, b)]
to_bind_pair (a
bndr, Just b
rhs) [(a, b)]
rest = (a
bndr, b
rhs) forall a. a -> [a] -> [a]
: [(a, b)]
rest
to_bind_pair (a
_, Maybe b
Nothing) [(a, b)]
rest = [(a, b)]
rest
TcGblEnv
tcg_env <- forall a. [Var] -> TcM a -> TcM a
tcExtendGlobalValEnv (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Var, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))]
rep_binds) forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
let binds :: [GenLocated
SrcSpanAnnA
(HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))]
binds = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind) [(Var, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))]
rep_binds
tcg_env' :: TcGblEnv
tcg_env' = TcGblEnv
tcg_env TcGblEnv -> [LHsBinds (GhcPass 'Typechecked)] -> TcGblEnv
`addTypecheckedBinds` [forall a. [a] -> Bag a
listToBag [GenLocated
SrcSpanAnnA
(HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))]
binds]
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 (GhcPass 'Typechecked))
getKindRep stuff :: TypeableStuff
stuff@(Stuff {Platform
TyCon
DataCon
FastString -> LHsExpr (GhcPass 'Typechecked)
typeLitNatDataCon :: DataCon
typeLitCharDataCon :: DataCon
typeLitSymbolDataCon :: DataCon
kindRepTypeLitSDataCon :: DataCon
kindRepTYPEDataCon :: DataCon
kindRepFunDataCon :: DataCon
kindRepAppDataCon :: DataCon
kindRepVarDataCon :: DataCon
kindRepTyConAppDataCon :: DataCon
kindRepTyCon :: TyCon
trNameLit :: FastString -> LHsExpr (GhcPass 'Typechecked)
trTyConDataCon :: DataCon
platform :: Platform
typeLitNatDataCon :: TypeableStuff -> DataCon
typeLitCharDataCon :: TypeableStuff -> DataCon
typeLitSymbolDataCon :: TypeableStuff -> DataCon
kindRepTypeLitSDataCon :: TypeableStuff -> DataCon
kindRepTYPEDataCon :: TypeableStuff -> DataCon
kindRepFunDataCon :: TypeableStuff -> DataCon
kindRepAppDataCon :: TypeableStuff -> DataCon
kindRepVarDataCon :: TypeableStuff -> DataCon
kindRepTyConAppDataCon :: TypeableStuff -> DataCon
kindRepTyCon :: TypeableStuff -> TyCon
trNameLit :: TypeableStuff -> FastString -> LHsExpr (GhcPass 'Typechecked)
trTyConDataCon :: TypeableStuff -> DataCon
platform :: TypeableStuff -> Platform
..}) CmEnv
in_scope = Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
go
where
go :: Kind -> KindRepM (LHsExpr GhcTc)
go :: Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
go = forall a. StateT KindRepEnv TcRn a -> KindRepM a
KindRepM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type
-> KindRepEnv -> TcRn (LHsExpr (GhcPass 'Typechecked), KindRepEnv)
go'
go' :: Kind -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv)
go' :: Type
-> KindRepEnv -> TcRn (LHsExpr (GhcPass 'Typechecked), KindRepEnv)
go' Type
k KindRepEnv
env
| Just Type
k' <- Type -> Maybe Type
tcView Type
k = Type
-> KindRepEnv -> TcRn (LHsExpr (GhcPass 'Typechecked), KindRepEnv)
go' Type
k' KindRepEnv
env
| Just (Var
id, Maybe (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
_) <- forall a. TypeMap a -> CmEnv -> Type -> Maybe a
lookupTypeMapWithScope KindRepEnv
env CmEnv
in_scope Type
k
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar Var
id, KindRepEnv
env)
| Bool
otherwise
= do
Var
rep_bndr <- (Var -> InlinePragma -> Var
`setInlinePragma` InlinePragma
neverInlinePragma)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall gbl lcl. FastString -> Type -> Type -> TcRnIf gbl lcl Var
newSysLocalId (String -> FastString
fsLit String
"$krep") Type
Many (TyCon -> Type
mkTyConTy TyCon
kindRepTyCon)
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT KindRepEnv
env forall a b. (a -> b) -> a -> b
$ forall a. KindRepM a -> StateT KindRepEnv TcRn a
unKindRepM forall a b. (a -> b) -> a -> b
$ do
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rhs <- TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
mkKindRepRhs TypeableStuff
stuff CmEnv
in_scope Type
k
CmEnv
-> Type -> Var -> LHsExpr (GhcPass 'Typechecked) -> KindRepM ()
addKindRepBind CmEnv
in_scope Type
k Var
rep_bndr GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rhs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar Var
rep_bndr
mkKindRepRhs :: TypeableStuff
-> CmEnv
-> Kind
-> KindRepM (LHsExpr GhcTc)
mkKindRepRhs :: TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
mkKindRepRhs stuff :: TypeableStuff
stuff@(Stuff {Platform
TyCon
DataCon
FastString -> LHsExpr (GhcPass 'Typechecked)
typeLitNatDataCon :: DataCon
typeLitCharDataCon :: DataCon
typeLitSymbolDataCon :: DataCon
kindRepTypeLitSDataCon :: DataCon
kindRepTYPEDataCon :: DataCon
kindRepFunDataCon :: DataCon
kindRepAppDataCon :: DataCon
kindRepVarDataCon :: DataCon
kindRepTyConAppDataCon :: DataCon
kindRepTyCon :: TyCon
trNameLit :: FastString -> LHsExpr (GhcPass 'Typechecked)
trTyConDataCon :: DataCon
platform :: Platform
typeLitNatDataCon :: TypeableStuff -> DataCon
typeLitCharDataCon :: TypeableStuff -> DataCon
typeLitSymbolDataCon :: TypeableStuff -> DataCon
kindRepTypeLitSDataCon :: TypeableStuff -> DataCon
kindRepTYPEDataCon :: TypeableStuff -> DataCon
kindRepFunDataCon :: TypeableStuff -> DataCon
kindRepAppDataCon :: TypeableStuff -> DataCon
kindRepVarDataCon :: TypeableStuff -> DataCon
kindRepTyConAppDataCon :: TypeableStuff -> DataCon
kindRepTyCon :: TypeableStuff -> TyCon
trNameLit :: TypeableStuff -> FastString -> LHsExpr (GhcPass 'Typechecked)
trTyConDataCon :: TypeableStuff -> DataCon
platform :: TypeableStuff -> Platform
..}) CmEnv
in_scope = Type
-> KindRepM
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
new_kind_rep_shortcut
where
new_kind_rep_shortcut :: Type
-> KindRepM
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
new_kind_rep_shortcut Type
k
| Bool -> Bool
not (Type -> Bool
tcIsConstraintKind Type
k)
, Just Type
arg <- HasDebugCallStack => Type -> Maybe Type
kindRep_maybe Type
k
= case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
arg of
Just (TyCon
tc, [])
| Just DataCon
dc <- TyCon -> Maybe DataCon
isPromotedDataCon_maybe TyCon
tc
-> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepTYPEDataCon forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
dc
Just (TyCon
rep, [Type
levArg])
| Just DataCon
dcRep <- TyCon -> Maybe DataCon
isPromotedDataCon_maybe TyCon
rep
, Just (TyCon
lev, []) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
levArg
, Just DataCon
dcLev <- TyCon -> Maybe DataCon
isPromotedDataCon_maybe TyCon
lev
-> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepTYPEDataCon forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` (DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
dcRep forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
dcLev)
Maybe (TyCon, [Type])
_ -> Type
-> KindRepM
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
new_kind_rep Type
k
| Bool
otherwise = Type
-> KindRepM
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
new_kind_rep Type
k
new_kind_rep :: Type
-> KindRepM
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
new_kind_rep (TyVarTy Var
v)
| Just Int
idx <- CmEnv -> Var -> Maybe Int
lookupCME CmEnv
in_scope Var
v
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepVarDataCon
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
idx)
| Bool
otherwise
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTyConKindRepBinds.go(tyvar)" (forall a. Outputable a => a -> SDoc
ppr Var
v)
new_kind_rep (AppTy Type
t1 Type
t2)
= do GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rep1 <- TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
getKindRep TypeableStuff
stuff CmEnv
in_scope Type
t1
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rep2 <- TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
getKindRep TypeableStuff
stuff CmEnv
in_scope Type
t2
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepAppDataCon
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rep1 forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rep2
new_kind_rep k :: Type
k@(TyConApp TyCon
tc [Type]
tys)
| Just Name
rep_name <- TyCon -> Maybe Name
tyConRepName_maybe TyCon
tc
= do Var
rep_id <- forall a. TcRn a -> KindRepM a
liftTc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThings m => Name -> m Var
lookupId Name
rep_name
[GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))]
tys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
getKindRep TypeableStuff
stuff CmEnv
in_scope) [Type]
tys
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepTyConAppDataCon
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar Var
rep_id
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` Type
-> [LHsExpr (GhcPass 'Typechecked)]
-> LHsExpr (GhcPass 'Typechecked)
mkList (TyCon -> Type
mkTyConTy TyCon
kindRepTyCon) [GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))]
tys'
| Bool
otherwise
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTyConKindRepBinds(TyConApp)" (forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Type
k)
new_kind_rep (ForAllTy (Bndr Var
var ArgFlag
_) Type
ty)
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTyConKindRepBinds(ForAllTy)" (forall a. Outputable a => a -> SDoc
ppr Var
var SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Type
ty)
new_kind_rep (FunTy AnonArgFlag
_ Type
_ Type
t1 Type
t2)
= do GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rep1 <- TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
getKindRep TypeableStuff
stuff CmEnv
in_scope Type
t1
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rep2 <- TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
getKindRep TypeableStuff
stuff CmEnv
in_scope Type
t2
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepFunDataCon
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rep1 forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
rep2
new_kind_rep (LitTy (NumTyLit Integer
n))
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepTypeLitSDataCon
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
typeLitNatDataCon
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (forall (p :: Pass). FastString -> HsLit (GhcPass p)
mkHsStringPrimLit forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Integer
n)
new_kind_rep (LitTy (StrTyLit FastString
s))
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepTypeLitSDataCon
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
typeLitSymbolDataCon
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (forall (p :: Pass). FastString -> HsLit (GhcPass p)
mkHsStringPrimLit forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show FastString
s)
new_kind_rep (LitTy (CharTyLit Char
c))
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepTypeLitSDataCon
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
typeLitCharDataCon
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (forall (p :: Pass). Char -> HsLit (GhcPass p)
mkHsCharPrimLit Char
c)
new_kind_rep (CastTy Type
ty KindCoercion
co)
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTyConKindRepBinds.go(cast)" (forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr KindCoercion
co)
new_kind_rep (CoercionTy KindCoercion
co)
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTyConKindRepBinds.go(coercion)" (forall a. Outputable a => a -> SDoc
ppr KindCoercion
co)
mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo
-> TyCon
-> LHsExpr GhcTc
-> LHsExpr GhcTc
mkTyConRepTyConRHS :: TypeableStuff
-> TypeRepTodo
-> TyCon
-> LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked)
mkTyConRepTyConRHS (Stuff {Platform
TyCon
DataCon
FastString -> LHsExpr (GhcPass 'Typechecked)
typeLitNatDataCon :: DataCon
typeLitCharDataCon :: DataCon
typeLitSymbolDataCon :: DataCon
kindRepTypeLitSDataCon :: DataCon
kindRepTYPEDataCon :: DataCon
kindRepFunDataCon :: DataCon
kindRepAppDataCon :: DataCon
kindRepVarDataCon :: DataCon
kindRepTyConAppDataCon :: DataCon
kindRepTyCon :: TyCon
trNameLit :: FastString -> LHsExpr (GhcPass 'Typechecked)
trTyConDataCon :: DataCon
platform :: Platform
typeLitNatDataCon :: TypeableStuff -> DataCon
typeLitCharDataCon :: TypeableStuff -> DataCon
typeLitSymbolDataCon :: TypeableStuff -> DataCon
kindRepTypeLitSDataCon :: TypeableStuff -> DataCon
kindRepTYPEDataCon :: TypeableStuff -> DataCon
kindRepFunDataCon :: TypeableStuff -> DataCon
kindRepAppDataCon :: TypeableStuff -> DataCon
kindRepVarDataCon :: TypeableStuff -> DataCon
kindRepTyConAppDataCon :: TypeableStuff -> DataCon
kindRepTyCon :: TypeableStuff -> TyCon
trNameLit :: TypeableStuff -> FastString -> LHsExpr (GhcPass 'Typechecked)
trTyConDataCon :: TypeableStuff -> DataCon
platform :: TypeableStuff -> Platform
..}) TypeRepTodo
todo TyCon
tycon LHsExpr (GhcPass 'Typechecked)
kind_rep
= DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
trTyConDataCon
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (Platform -> Word64 -> HsLit (GhcPass 'Typechecked)
word64 Platform
platform Word64
high)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (Platform -> Word64 -> HsLit (GhcPass 'Typechecked)
word64 Platform
platform Word64
low)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` TypeRepTodo -> LHsExpr (GhcPass 'Typechecked)
mod_rep_expr TypeRepTodo
todo
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` FastString -> LHsExpr (GhcPass 'Typechecked)
trNameLit (String -> FastString
mkFastString String
tycon_str)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (Int -> HsLit (GhcPass 'Typechecked)
int Int
n_kind_vars)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr (GhcPass 'Typechecked)
kind_rep
where
n_kind_vars :: Int
n_kind_vars = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ 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 (forall a. NamedThing a => a -> OccName
getOccName TyCon
tycon))
add_tick :: String -> String
add_tick String
s | TyCon -> Bool
isPromotedDataCon TyCon
tycon = Char
'\'' 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
]
int :: Int -> HsLit GhcTc
int :: Int -> HsLit (GhcPass 'Typechecked)
int Int
n = forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim (String -> SourceText
SourceText forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
n) (forall a. Integral a => a -> Integer
toInteger Int
n)
word64 :: Platform -> Word64 -> HsLit GhcTc
word64 :: Platform -> Word64 -> HsLit (GhcPass 'Typechecked)
word64 Platform
platform Word64
n = case Platform -> PlatformWordSize
platformWordSize Platform
platform of
PlatformWordSize
PW4 -> forall x. XHsWord64Prim x -> Integer -> HsLit x
HsWord64Prim SourceText
NoSourceText (forall a. Integral a => a -> Integer
toInteger Word64
n)
PlatformWordSize
PW8 -> forall x. XHsWordPrim x -> Integer -> HsLit x
HsWordPrim SourceText
NoSourceText (forall a. Integral a => a -> Integer
toInteger Word64
n)
mkList :: Type -> [LHsExpr GhcTc] -> LHsExpr GhcTc
mkList :: Type
-> [LHsExpr (GhcPass 'Typechecked)]
-> LHsExpr (GhcPass 'Typechecked)
mkList Type
ty = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
consApp (Type -> LHsExpr (GhcPass 'Typechecked)
nilExpr Type
ty)
where
cons :: LHsExpr (GhcPass 'Typechecked)
cons = Type -> LHsExpr (GhcPass 'Typechecked)
consExpr Type
ty
consApp :: LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
consApp :: LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
consApp LHsExpr (GhcPass 'Typechecked)
x LHsExpr (GhcPass 'Typechecked)
xs = LHsExpr (GhcPass 'Typechecked)
cons forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr (GhcPass 'Typechecked)
x forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr (GhcPass 'Typechecked)
xs
nilExpr :: Type -> LHsExpr GhcTc
nilExpr :: Type -> LHsExpr (GhcPass 'Typechecked)
nilExpr Type
ty = HsWrapper
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
mkLHsWrap ([Type] -> HsWrapper
mkWpTyApps [Type
ty]) (DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
nilDataCon)
consExpr :: Type -> LHsExpr GhcTc
consExpr :: Type -> LHsExpr (GhcPass 'Typechecked)
consExpr Type
ty = HsWrapper
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
mkLHsWrap ([Type] -> HsWrapper
mkWpTyApps [Type
ty]) (DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
consDataCon)