{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module TcTypeable(mkTypeableBinds, tyConIsTypeable) where
#include "HsVersions.h"
import GhcPrelude
import BasicTypes ( Boxity(..), neverInlinePragma, SourceText(..) )
import IfaceEnv( newGlobalBinder )
import TyCoRep( Type(..), TyLit(..) )
import TcEnv
import TcEvidence ( mkWpTyApps )
import TcRnMonad
import TcType
import HscTypes ( lookupId )
import PrelNames
import TysPrim ( primTyCons )
import TysWiredIn ( tupleTyCon, sumTyCon, runtimeRepTyCon
, vecCountTyCon, vecElemTyCon
, nilDataCon, consDataCon )
import Name
import Id
import Type
import TyCon
import DataCon
import Module
import GHC.Hs
import DynFlags
import Bag
import Var ( VarBndr(..) )
import CoreMap
import Constants
import Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints)
import Outputable
import 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 <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NoTypeableBinds DynFlags
dflags then TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv else do
{
; TcGblEnv
tcg_env <- TcM TcGblEnv
mkModIdBindings
; (TcGblEnv
tcg_env, [TypeRepTodo]
prim_todos) <- TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, [TypeRepTodo])
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, [TypeRepTodo])
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env TcRnIf TcGblEnv TcLclEnv (TcGblEnv, [TypeRepTodo])
mkPrimTypeableTodos
; TcGblEnv -> TcM TcGblEnv -> TcM TcGblEnv
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
do { Module
mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; let tycons :: [TyCon]
tycons = (TyCon -> Bool) -> [TyCon] -> [TyCon]
forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
needs_typeable_binds (TcGblEnv -> [TyCon]
tcg_tcs TcGblEnv
tcg_env)
mod_id :: Id
mod_id = case TcGblEnv -> Maybe Id
tcg_tr_module TcGblEnv
tcg_env of
Just Id
mod_id -> Id
mod_id
Maybe Id
Nothing -> String -> SDoc -> Id
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcMkTypeableBinds" ([TyCon] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyCon]
tycons)
; String -> SDoc -> TcRn ()
traceTc String
"mkTypeableBinds" ([TyCon] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyCon]
tycons)
; TypeRepTodo
this_mod_todos <- Module -> Id -> [TyCon] -> TcM TypeRepTodo
todoForTyCons Module
mod Id
mod_id [TyCon]
tycons
; [TypeRepTodo] -> TcM TcGblEnv
mkTypeRepTodoBinds (TypeRepTodo
this_mod_todos TypeRepTodo -> [TypeRepTodo] -> [TypeRepTodo]
forall a. a -> [a] -> [a]
: [TypeRepTodo]
prim_todos)
} } }
where
needs_typeable_binds :: TyCon -> Bool
needs_typeable_binds TyCon
tc
| TyCon
tc TyCon -> [TyCon] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TyCon
runtimeRepTyCon, 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 <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; Name
mod_nm <- Module -> OccName -> SrcSpan -> TcRnIf TcGblEnv TcLclEnv Name
forall a b. Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder Module
mod (String -> OccName
mkVarOcc String
"$trModule") SrcSpan
loc
; TyCon
trModuleTyCon <- Name -> TcM TyCon
tcLookupTyCon Name
trModuleTyConName
; let mod_id :: Id
mod_id = Name -> Type -> Id
mkExportedVanillaId Name
mod_nm (TyCon -> [Type] -> Type
mkTyConApp TyCon
trModuleTyCon [])
; LHsBind (GhcPass 'Typechecked)
mod_bind <- IdP (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsBind (GhcPass 'Typechecked)
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind Id
IdP (GhcPass 'Typechecked)
mod_id (LHsExpr (GhcPass 'Typechecked) -> LHsBind (GhcPass 'Typechecked))
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr (GhcPass 'Typechecked))
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsBind (GhcPass 'Typechecked))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Module
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr (GhcPass 'Typechecked))
mkModIdRHS Module
mod
; TcGblEnv
tcg_env <- [Id] -> TcM TcGblEnv -> TcM TcGblEnv
forall a. [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv [Id
mod_id] TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env { tcg_tr_module :: Maybe Id
tcg_tr_module = Id -> Maybe Id
forall a. a -> Maybe a
Just Id
mod_id }
TcGblEnv -> [LHsBinds (GhcPass 'Typechecked)] -> TcGblEnv
`addTypecheckedBinds` [LHsBind (GhcPass 'Typechecked) -> LHsBinds (GhcPass 'Typechecked)
forall a. a -> Bag a
unitBag LHsBind (GhcPass 'Typechecked)
mod_bind]) }
mkModIdRHS :: Module -> TcM (LHsExpr GhcTc)
mkModIdRHS :: Module
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr (GhcPass 'Typechecked))
mkModIdRHS Module
mod
= do { DataCon
trModuleDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
trModuleDataConName
; FastString -> LHsExpr (GhcPass 'Typechecked)
trNameLit <- TcM (FastString -> LHsExpr (GhcPass 'Typechecked))
mkTrNameLit
; LHsExpr (GhcPass 'Typechecked)
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr (GhcPass 'Typechecked))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr (GhcPass 'Typechecked)
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr (GhcPass 'Typechecked)))
-> LHsExpr (GhcPass 'Typechecked)
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr (GhcPass 'Typechecked))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
trModuleDataCon
LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` FastString -> LHsExpr (GhcPass 'Typechecked)
trNameLit (UnitId -> FastString
unitIdFS (Module -> UnitId
moduleUnitId Module
mod))
LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` FastString -> LHsExpr (GhcPass 'Typechecked)
trNameLit (ModuleName -> FastString
moduleNameFS (Module -> ModuleName
moduleName Module
mod))
}
data TypeableTyCon
= TypeableTyCon
{ TypeableTyCon -> TyCon
tycon :: !TyCon
, TypeableTyCon -> Id
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 -> Id -> [TyCon] -> TcM TypeRepTodo
todoForTyCons Module
mod Id
mod_id [TyCon]
tycons = do
Type
trTyConTy <- TyCon -> Type
mkTyConTy (TyCon -> Type) -> TcM TyCon -> IOEnv (Env TcGblEnv TcLclEnv) Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TcM TyCon
tcLookupTyCon Name
trTyConTyConName
let mk_rep_id :: TyConRepName -> Id
mk_rep_id :: Name -> Id
mk_rep_id Name
rep_name = Name -> Type -> Id
mkExportedVanillaId Name
rep_name Type
trTyConTy
let typeable_tycons :: [TypeableTyCon]
typeable_tycons :: [TypeableTyCon]
typeable_tycons =
[ TypeableTyCon :: TyCon -> Id -> TypeableTyCon
TypeableTyCon { tycon :: TyCon
tycon = TyCon
tc''
, tycon_rep_id :: Id
tycon_rep_id = Name -> Id
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 (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Name -> [Maybe Name]) -> Maybe Name -> [Maybe Name]
forall a b. (a -> b) -> a -> b
$ TyCon -> Maybe Name
tyConRepName_maybe TyCon
tc''
, TyCon -> Bool
tyConIsTypeable TyCon
tc''
]
TypeRepTodo -> TcM TypeRepTodo
forall (m :: * -> *) a. Monad m => a -> m a
return TypeRepTodo :: LHsExpr (GhcPass 'Typechecked)
-> Fingerprint -> Fingerprint -> [TypeableTyCon] -> TypeRepTodo
TypeRepTodo { mod_rep_expr :: LHsExpr (GhcPass 'Typechecked)
mod_rep_expr = IdP (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Id
IdP (GhcPass 'Typechecked)
mod_id
, pkg_fingerprint :: Fingerprint
pkg_fingerprint = Fingerprint
pkg_fpr
, mod_fingerprint :: Fingerprint
mod_fingerprint = Fingerprint
mod_fpr
, todo_tycons :: [TypeableTyCon]
todo_tycons = [TypeableTyCon]
typeable_tycons
}
where
mod_fpr :: Fingerprint
mod_fpr = String -> Fingerprint
fingerprintString (String -> Fingerprint) -> String -> Fingerprint
forall a b. (a -> b) -> a -> b
$ ModuleName -> String
moduleNameString (ModuleName -> String) -> ModuleName -> String
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
moduleName Module
mod
pkg_fpr :: Fingerprint
pkg_fpr = String -> Fingerprint
fingerprintString (String -> Fingerprint) -> String -> Fingerprint
forall a b. (a -> b) -> a -> b
$ UnitId -> String
unitIdString (UnitId -> String) -> UnitId -> String
forall a b. (a -> b) -> a -> b
$ Module -> UnitId
moduleUnitId Module
mod
todoForExportedKindReps :: [(Kind, Name)] -> TcM TypeRepTodo
todoForExportedKindReps :: [(Type, Name)] -> TcM TypeRepTodo
todoForExportedKindReps [(Type, Name)]
kinds = do
Type
trKindRepTy <- TyCon -> Type
mkTyConTy (TyCon -> Type) -> TcM TyCon -> IOEnv (Env TcGblEnv TcLclEnv) Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TcM TyCon
tcLookupTyCon Name
kindRepTyConName
let mkId :: (Type, Name) -> (Type, Id)
mkId (Type
k, Name
name) = (Type
k, Name -> Type -> Id
mkExportedVanillaId Name
name Type
trKindRepTy)
TypeRepTodo -> TcM TypeRepTodo
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeRepTodo -> TcM TypeRepTodo) -> TypeRepTodo -> TcM TypeRepTodo
forall a b. (a -> b) -> a -> b
$ [(Type, Id)] -> TypeRepTodo
ExportedKindRepsTodo ([(Type, Id)] -> TypeRepTodo) -> [(Type, Id)] -> TypeRepTodo
forall a b. (a -> b) -> a -> b
$ ((Type, Name) -> (Type, Id)) -> [(Type, Name)] -> [(Type, Id)]
forall a b. (a -> b) -> [a] -> [b]
map (Type, Name) -> (Type, Id)
mkId [(Type, Name)]
kinds
mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv
mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv
mkTypeRepTodoBinds [] = TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
mkTypeRepTodoBinds [TypeRepTodo]
todos
= do { TypeableStuff
stuff <- TcM TypeableStuff
collect_stuff
; let produced_bndrs :: [Id]
produced_bndrs :: [Id]
produced_bndrs = [ Id
tycon_rep_id
| todo :: TypeRepTodo
todo@(TypeRepTodo{}) <- [TypeRepTodo]
todos
, TypeableTyCon {TyCon
Id
tycon :: TyCon
tycon_rep_id :: Id
tycon_rep_id :: TypeableTyCon -> Id
tycon :: TypeableTyCon -> TyCon
..} <- TypeRepTodo -> [TypeableTyCon]
todo_tycons TypeRepTodo
todo
] [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++
[ Id
rep_id
| ExportedKindRepsTodo [(Type, Id)]
kinds <- [TypeRepTodo]
todos
, (Type
_, Id
rep_id) <- [(Type, Id)]
kinds
]
; TcGblEnv
gbl_env <- [Id] -> TcM TcGblEnv -> TcM TcGblEnv
forall a. [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv [Id]
produced_bndrs TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds GhcTc]
mk_binds :: TypeRepTodo -> KindRepM [LHsBinds (GhcPass 'Typechecked)]
mk_binds todo :: TypeRepTodo
todo@(TypeRepTodo {}) =
(TypeableTyCon -> KindRepM (LHsBinds (GhcPass 'Typechecked)))
-> [TypeableTyCon] -> KindRepM [LHsBinds (GhcPass 'Typechecked)]
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, Id)]
kinds) =
TypeableStuff -> [(Type, Id)] -> KindRepM ()
mkExportedKindReps TypeableStuff
stuff [(Type, Id)]
kinds KindRepM ()
-> KindRepM [LHsBinds (GhcPass 'Typechecked)]
-> KindRepM [LHsBinds (GhcPass 'Typechecked)]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [LHsBinds (GhcPass 'Typechecked)]
-> KindRepM [LHsBinds (GhcPass 'Typechecked)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
; (TcGblEnv
gbl_env, [[LHsBinds (GhcPass 'Typechecked)]]
binds) <- TcGblEnv
-> TcRnIf
TcGblEnv TcLclEnv (TcGblEnv, [[LHsBinds (GhcPass 'Typechecked)]])
-> TcRnIf
TcGblEnv TcLclEnv (TcGblEnv, [[LHsBinds (GhcPass 'Typechecked)]])
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
gbl_env
(TcRnIf
TcGblEnv TcLclEnv (TcGblEnv, [[LHsBinds (GhcPass 'Typechecked)]])
-> TcRnIf
TcGblEnv TcLclEnv (TcGblEnv, [[LHsBinds (GhcPass 'Typechecked)]]))
-> TcRnIf
TcGblEnv TcLclEnv (TcGblEnv, [[LHsBinds (GhcPass 'Typechecked)]])
-> TcRnIf
TcGblEnv TcLclEnv (TcGblEnv, [[LHsBinds (GhcPass 'Typechecked)]])
forall a b. (a -> b) -> a -> b
$ KindRepM [[LHsBinds (GhcPass 'Typechecked)]]
-> TcRnIf
TcGblEnv TcLclEnv (TcGblEnv, [[LHsBinds (GhcPass 'Typechecked)]])
forall a. KindRepM a -> TcRn (TcGblEnv, a)
runKindRepM ((TypeRepTodo -> KindRepM [LHsBinds (GhcPass 'Typechecked)])
-> [TypeRepTodo] -> KindRepM [[LHsBinds (GhcPass 'Typechecked)]]
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)
; TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> TcM TcGblEnv) -> TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$ TcGblEnv
gbl_env TcGblEnv -> [LHsBinds (GhcPass 'Typechecked)] -> TcGblEnv
`addTypecheckedBinds` [[LHsBinds (GhcPass 'Typechecked)]]
-> [LHsBinds (GhcPass 'Typechecked)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[LHsBinds (GhcPass 'Typechecked)]]
binds }
mkPrimTypeableTodos :: TcM (TcGblEnv, [TypeRepTodo])
mkPrimTypeableTodos :: TcRnIf TcGblEnv TcLclEnv (TcGblEnv, [TypeRepTodo])
mkPrimTypeableTodos
= do { Module
mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; if Module
mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
gHC_TYPES
then do {
TyCon
trModuleTyCon <- Name -> TcM TyCon
tcLookupTyCon Name
trModuleTyConName
; let ghc_prim_module_id :: Id
ghc_prim_module_id =
Name -> Type -> Id
mkExportedVanillaId Name
trGhcPrimModuleName
(TyCon -> Type
mkTyConTy TyCon
trModuleTyCon)
; LHsBind (GhcPass 'Typechecked)
ghc_prim_module_bind <- IdP (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsBind (GhcPass 'Typechecked)
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind Id
IdP (GhcPass 'Typechecked)
ghc_prim_module_id
(LHsExpr (GhcPass 'Typechecked) -> LHsBind (GhcPass 'Typechecked))
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr (GhcPass 'Typechecked))
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsBind (GhcPass 'Typechecked))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Module
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr (GhcPass 'Typechecked))
mkModIdRHS Module
gHC_PRIM
; TcGblEnv
gbl_env <- [Id] -> TcM TcGblEnv -> TcM TcGblEnv
forall a. [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv [Id
ghc_prim_module_id]
TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let gbl_env' :: TcGblEnv
gbl_env' = TcGblEnv
gbl_env TcGblEnv -> [LHsBinds (GhcPass 'Typechecked)] -> TcGblEnv
`addTypecheckedBinds`
[LHsBind (GhcPass 'Typechecked) -> LHsBinds (GhcPass 'Typechecked)
forall a. a -> Bag a
unitBag LHsBind (GhcPass 'Typechecked)
ghc_prim_module_bind]
; TypeRepTodo
todo1 <- [(Type, Name)] -> TcM TypeRepTodo
todoForExportedKindReps [(Type, Name)]
builtInKindReps
; TypeRepTodo
todo2 <- Module -> Id -> [TyCon] -> TcM TypeRepTodo
todoForTyCons Module
gHC_PRIM Id
ghc_prim_module_id
[TyCon]
ghcPrimTypeableTyCons
; (TcGblEnv, [TypeRepTodo])
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, [TypeRepTodo])
forall (m :: * -> *) a. Monad m => a -> m a
return ( TcGblEnv
gbl_env' , [TypeRepTodo
todo1, TypeRepTodo
todo2])
}
else do TcGblEnv
gbl_env <- TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
(TcGblEnv, [TypeRepTodo])
-> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, [TypeRepTodo])
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
gbl_env, [])
}
ghcPrimTypeableTyCons :: [TyCon]
ghcPrimTypeableTyCons :: [TyCon]
ghcPrimTypeableTyCons = [[TyCon]] -> [TyCon]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ TyCon
runtimeRepTyCon, TyCon
vecCountTyCon, TyCon
vecElemTyCon, TyCon
funTyCon ]
, (Arity -> TyCon) -> [Arity] -> [TyCon]
forall a b. (a -> b) -> [a] -> [b]
map (Boxity -> Arity -> TyCon
tupleTyCon Boxity
Unboxed) [Arity
0..Arity
mAX_TUPLE_SIZE]
, (Arity -> TyCon) -> [Arity] -> [TyCon]
forall a b. (a -> b) -> [a] -> [b]
map Arity -> TyCon
sumTyCon [Arity
2..Arity
mAX_SUM_SIZE]
, [TyCon]
primTyCons
]
data TypeableStuff
= Stuff { TypeableStuff -> DynFlags
dflags :: DynFlags
, 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
typeLitNatDataCon :: DataCon
}
collect_stuff :: TcM TypeableStuff
collect_stuff :: TcM TypeableStuff
collect_stuff = do
DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
DataCon
trTyConDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
trTyConDataConName
TyCon
kindRepTyCon <- Name -> TcM TyCon
tcLookupTyCon Name
kindRepTyConName
DataCon
kindRepTyConAppDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepTyConAppDataConName
DataCon
kindRepVarDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepVarDataConName
DataCon
kindRepAppDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepAppDataConName
DataCon
kindRepFunDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepFunDataConName
DataCon
kindRepTYPEDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepTYPEDataConName
DataCon
kindRepTypeLitSDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
kindRepTypeLitSDataConName
DataCon
typeLitSymbolDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
typeLitSymbolDataConName
DataCon
typeLitNatDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
typeLitNatDataConName
FastString -> LHsExpr (GhcPass 'Typechecked)
trNameLit <- TcM (FastString -> LHsExpr (GhcPass 'Typechecked))
mkTrNameLit
TypeableStuff -> TcM TypeableStuff
forall (m :: * -> *) a. Monad m => a -> m a
return Stuff :: DynFlags
-> DataCon
-> (FastString -> LHsExpr (GhcPass 'Typechecked))
-> TyCon
-> DataCon
-> DataCon
-> DataCon
-> DataCon
-> DataCon
-> DataCon
-> DataCon
-> DataCon
-> TypeableStuff
Stuff {DynFlags
TyCon
DataCon
FastString -> LHsExpr (GhcPass 'Typechecked)
trNameLit :: FastString -> LHsExpr (GhcPass 'Typechecked)
typeLitNatDataCon :: DataCon
typeLitSymbolDataCon :: DataCon
kindRepTypeLitSDataCon :: DataCon
kindRepTYPEDataCon :: DataCon
kindRepFunDataCon :: DataCon
kindRepAppDataCon :: DataCon
kindRepVarDataCon :: DataCon
kindRepTyConAppDataCon :: DataCon
kindRepTyCon :: TyCon
trTyConDataCon :: DataCon
dflags :: DynFlags
typeLitNatDataCon :: DataCon
typeLitSymbolDataCon :: DataCon
kindRepTypeLitSDataCon :: DataCon
kindRepTYPEDataCon :: DataCon
kindRepFunDataCon :: DataCon
kindRepAppDataCon :: DataCon
kindRepVarDataCon :: DataCon
kindRepTyConAppDataCon :: DataCon
kindRepTyCon :: TyCon
trNameLit :: FastString -> LHsExpr (GhcPass 'Typechecked)
trTyConDataCon :: DataCon
dflags :: DynFlags
..}
mkTrNameLit :: TcM (FastString -> LHsExpr GhcTc)
mkTrNameLit :: TcM (FastString -> LHsExpr (GhcPass 'Typechecked))
mkTrNameLit = do
DataCon
trNameSDataCon <- Name -> TcM DataCon
tcLookupDataCon Name
trNameSDataConName
let trNameLit :: FastString -> LHsExpr GhcTc
trNameLit :: FastString -> LHsExpr (GhcPass 'Typechecked)
trNameLit FastString
fs = LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked))
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
trNameSDataCon
LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (FastString -> HsLit (GhcPass 'Typechecked)
forall (p :: Pass). FastString -> HsLit (GhcPass p)
mkHsStringPrimLit FastString
fs)
(FastString -> LHsExpr (GhcPass 'Typechecked))
-> TcM (FastString -> LHsExpr (GhcPass 'Typechecked))
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 {TyCon
Id
tycon_rep_id :: Id
tycon :: TyCon
tycon_rep_id :: TypeableTyCon -> Id
tycon :: TypeableTyCon -> TyCon
..})
= do
let ([TyCoVarBinder]
bndrs, Type
kind) = Type -> ([TyCoVarBinder], Type)
splitForAllVarBndrs (TyCon -> Type
tyConKind TyCon
tycon)
TcRn () -> KindRepM ()
forall a. TcRn a -> KindRepM a
liftTc (TcRn () -> KindRepM ()) -> TcRn () -> KindRepM ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc -> TcRn ()
traceTc String
"mkTyConKindRepBinds"
(TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tycon SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Type
tyConKind TyCon
tycon) SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
kind)
let ctx :: CmEnv
ctx = [Id] -> CmEnv
mkDeBruijnContext ((TyCoVarBinder -> Id) -> [TyCoVarBinder] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map TyCoVarBinder -> Id
forall tv argf. VarBndr tv argf -> tv
binderVar [TyCoVarBinder]
bndrs)
LHsExpr (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 LHsExpr (GhcPass 'Typechecked)
kind_rep
tycon_rep_bind :: LHsBind (GhcPass 'Typechecked)
tycon_rep_bind = IdP (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsBind (GhcPass 'Typechecked)
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind Id
IdP (GhcPass 'Typechecked)
tycon_rep_id LHsExpr (GhcPass 'Typechecked)
tycon_rep_rhs
LHsBinds (GhcPass 'Typechecked)
-> KindRepM (LHsBinds (GhcPass 'Typechecked))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds (GhcPass 'Typechecked)
-> KindRepM (LHsBinds (GhcPass 'Typechecked)))
-> LHsBinds (GhcPass 'Typechecked)
-> KindRepM (LHsBinds (GhcPass 'Typechecked))
forall a b. (a -> b) -> a -> b
$ LHsBind (GhcPass 'Typechecked) -> LHsBinds (GhcPass 'Typechecked)
forall a. a -> Bag a
unitBag LHsBind (GhcPass 'Typechecked)
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 Id
_) = 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
a Type
b) = 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 { KindRepM a -> StateT KindRepEnv TcRn a
unKindRepM :: StateT KindRepEnv TcRn a }
deriving (a -> KindRepM b -> KindRepM a
(a -> b) -> KindRepM a -> KindRepM b
(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
<$ :: a -> KindRepM b -> KindRepM a
$c<$ :: forall a b. a -> KindRepM b -> KindRepM a
fmap :: (a -> b) -> KindRepM a -> KindRepM b
$cfmap :: forall a b. (a -> b) -> KindRepM a -> KindRepM b
Functor, Functor KindRepM
a -> KindRepM a
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
KindRepM a -> KindRepM b -> KindRepM b
KindRepM a -> KindRepM b -> KindRepM a
KindRepM (a -> b) -> KindRepM a -> KindRepM b
(a -> b -> c) -> KindRepM a -> KindRepM b -> KindRepM c
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
<* :: KindRepM a -> KindRepM b -> KindRepM a
$c<* :: forall a b. KindRepM a -> KindRepM b -> KindRepM a
*> :: KindRepM a -> KindRepM b -> KindRepM b
$c*> :: forall a b. KindRepM a -> KindRepM b -> KindRepM b
liftA2 :: (a -> b -> c) -> KindRepM a -> KindRepM b -> KindRepM c
$cliftA2 :: forall a b c.
(a -> b -> c) -> KindRepM a -> KindRepM b -> KindRepM c
<*> :: KindRepM (a -> b) -> KindRepM a -> KindRepM b
$c<*> :: forall a b. KindRepM (a -> b) -> KindRepM a -> KindRepM b
pure :: a -> KindRepM a
$cpure :: forall a. a -> KindRepM a
$cp1Applicative :: Functor KindRepM
Applicative, Applicative KindRepM
a -> KindRepM a
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
KindRepM a -> (a -> KindRepM b) -> KindRepM b
KindRepM a -> KindRepM b -> KindRepM b
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 :: a -> KindRepM a
$creturn :: forall a. a -> KindRepM a
>> :: KindRepM a -> KindRepM b -> KindRepM b
$c>> :: forall a b. KindRepM a -> KindRepM b -> KindRepM b
>>= :: KindRepM a -> (a -> KindRepM b) -> KindRepM b
$c>>= :: forall a b. KindRepM a -> (a -> KindRepM b) -> KindRepM b
$cp1Monad :: Applicative KindRepM
Monad)
liftTc :: TcRn a -> KindRepM a
liftTc :: TcRn a -> KindRepM a
liftTc = StateT KindRepEnv TcRn a -> KindRepM a
forall a. StateT KindRepEnv TcRn a -> KindRepM a
KindRepM (StateT KindRepEnv TcRn a -> KindRepM a)
-> (TcRn a -> StateT KindRepEnv TcRn a) -> TcRn a -> KindRepM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcRn a -> StateT KindRepEnv TcRn 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 -> Type -> Type
mkVisFunTy Type
star Type
star, Name
starArrStarKindRepName)
, ([Type] -> Type -> Type
mkVisFunTys [Type
star, Type
star] Type
star, Name
starArrStarArrStarKindRepName)
]
where
star :: Type
star = Type
liftedTypeKind
initialKindRepEnv :: TcRn KindRepEnv
initialKindRepEnv :: TcRn KindRepEnv
initialKindRepEnv = (KindRepEnv -> (Type, Name) -> TcRn KindRepEnv)
-> KindRepEnv -> [(Type, Name)] -> TcRn KindRepEnv
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM KindRepEnv -> (Type, Name) -> TcRn KindRepEnv
forall a.
TypeMap (Id, Maybe a)
-> (Type, Name)
-> IOEnv (Env TcGblEnv TcLclEnv) (TypeMap (Id, Maybe a))
add_kind_rep KindRepEnv
forall a. TypeMap a
emptyTypeMap [(Type, Name)]
builtInKindReps
where
add_kind_rep :: TypeMap (Id, Maybe a)
-> (Type, Name)
-> IOEnv (Env TcGblEnv TcLclEnv) (TypeMap (Id, Maybe a))
add_kind_rep TypeMap (Id, Maybe a)
acc (Type
k,Name
n) = do
Id
id <- Name -> TcM Id
tcLookupId Name
n
TypeMap (Id, Maybe a)
-> IOEnv (Env TcGblEnv TcLclEnv) (TypeMap (Id, Maybe a))
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeMap (Id, Maybe a)
-> IOEnv (Env TcGblEnv TcLclEnv) (TypeMap (Id, Maybe a)))
-> TypeMap (Id, Maybe a)
-> IOEnv (Env TcGblEnv TcLclEnv) (TypeMap (Id, Maybe a))
forall a b. (a -> b) -> a -> b
$! TypeMap (Id, Maybe a)
-> Type -> (Id, Maybe a) -> TypeMap (Id, Maybe a)
forall a. TypeMap a -> Type -> a -> TypeMap a
extendTypeMap TypeMap (Id, Maybe a)
acc Type
k (Id
id, Maybe a
forall a. Maybe a
Nothing)
mkExportedKindReps :: TypeableStuff
-> [(Kind, Id)]
-> KindRepM ()
mkExportedKindReps :: TypeableStuff -> [(Type, Id)] -> KindRepM ()
mkExportedKindReps TypeableStuff
stuff = ((Type, Id) -> KindRepM ()) -> [(Type, Id)] -> KindRepM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Type, Id) -> KindRepM ()
kindrep_binding
where
empty_scope :: CmEnv
empty_scope = [Id] -> CmEnv
mkDeBruijnContext []
kindrep_binding :: (Kind, Id) -> KindRepM ()
kindrep_binding :: (Type, Id) -> KindRepM ()
kindrep_binding (Type
kind, Id
rep_bndr) = do
LHsExpr (GhcPass 'Typechecked)
rhs <- TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
mkKindRepRhs TypeableStuff
stuff CmEnv
empty_scope Type
kind
CmEnv
-> Type -> Id -> LHsExpr (GhcPass 'Typechecked) -> KindRepM ()
addKindRepBind CmEnv
empty_scope Type
kind Id
rep_bndr LHsExpr (GhcPass 'Typechecked)
rhs
addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr GhcTc -> KindRepM ()
addKindRepBind :: CmEnv
-> Type -> Id -> LHsExpr (GhcPass 'Typechecked) -> KindRepM ()
addKindRepBind CmEnv
in_scope Type
k Id
bndr LHsExpr (GhcPass 'Typechecked)
rhs =
StateT KindRepEnv TcRn () -> KindRepM ()
forall a. StateT KindRepEnv TcRn a -> KindRepM a
KindRepM (StateT KindRepEnv TcRn () -> KindRepM ())
-> StateT KindRepEnv TcRn () -> KindRepM ()
forall a b. (a -> b) -> a -> b
$ (KindRepEnv -> KindRepEnv) -> StateT KindRepEnv TcRn ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((KindRepEnv -> KindRepEnv) -> StateT KindRepEnv TcRn ())
-> (KindRepEnv -> KindRepEnv) -> StateT KindRepEnv TcRn ()
forall a b. (a -> b) -> a -> b
$
\KindRepEnv
env -> KindRepEnv
-> CmEnv
-> Type
-> (Id, Maybe (LHsExpr (GhcPass 'Typechecked)))
-> KindRepEnv
forall a. TypeMap a -> CmEnv -> Type -> a -> TypeMap a
extendTypeMapWithScope KindRepEnv
env CmEnv
in_scope Type
k (Id
bndr, LHsExpr (GhcPass 'Typechecked)
-> Maybe (LHsExpr (GhcPass 'Typechecked))
forall a. a -> Maybe a
Just LHsExpr (GhcPass 'Typechecked)
rhs)
runKindRepM :: KindRepM a -> TcRn (TcGblEnv, a)
runKindRepM :: KindRepM a -> TcRn (TcGblEnv, a)
runKindRepM (KindRepM StateT KindRepEnv TcRn a
action) = do
KindRepEnv
kindRepEnv <- TcRn KindRepEnv
initialKindRepEnv
(a
res, KindRepEnv
reps_env) <- StateT KindRepEnv TcRn a -> KindRepEnv -> TcRn (a, KindRepEnv)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT KindRepEnv TcRn a
action KindRepEnv
kindRepEnv
let rep_binds :: [(Id, LHsExpr (GhcPass 'Typechecked))]
rep_binds = ((Id, Maybe (LHsExpr (GhcPass 'Typechecked)))
-> [(Id, LHsExpr (GhcPass 'Typechecked))]
-> [(Id, LHsExpr (GhcPass 'Typechecked))])
-> [(Id, LHsExpr (GhcPass 'Typechecked))]
-> KindRepEnv
-> [(Id, LHsExpr (GhcPass 'Typechecked))]
forall a b. (a -> b -> b) -> b -> TypeMap a -> b
foldTypeMap (Id, Maybe (LHsExpr (GhcPass 'Typechecked)))
-> [(Id, LHsExpr (GhcPass 'Typechecked))]
-> [(Id, LHsExpr (GhcPass 'Typechecked))]
forall a b. (a, Maybe b) -> [(a, b)] -> [(a, b)]
to_bind_pair [] KindRepEnv
reps_env
to_bind_pair :: (a, Maybe b) -> [(a, b)] -> [(a, b)]
to_bind_pair (a
bndr, Just b
rhs) [(a, b)]
rest = (a
bndr, b
rhs) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)]
rest
to_bind_pair (a
_, Maybe b
Nothing) [(a, b)]
rest = [(a, b)]
rest
TcGblEnv
tcg_env <- [Id] -> TcM TcGblEnv -> TcM TcGblEnv
forall a. [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv (((Id, LHsExpr (GhcPass 'Typechecked)) -> Id)
-> [(Id, LHsExpr (GhcPass 'Typechecked))] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, LHsExpr (GhcPass 'Typechecked)) -> Id
forall a b. (a, b) -> a
fst [(Id, LHsExpr (GhcPass 'Typechecked))]
rep_binds) TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
let binds :: [LHsBind (GhcPass 'Typechecked)]
binds = ((Id, LHsExpr (GhcPass 'Typechecked))
-> LHsBind (GhcPass 'Typechecked))
-> [(Id, LHsExpr (GhcPass 'Typechecked))]
-> [LHsBind (GhcPass 'Typechecked)]
forall a b. (a -> b) -> [a] -> [b]
map ((Id
-> LHsExpr (GhcPass 'Typechecked)
-> LHsBind (GhcPass 'Typechecked))
-> (Id, LHsExpr (GhcPass 'Typechecked))
-> LHsBind (GhcPass 'Typechecked)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Id
-> LHsExpr (GhcPass 'Typechecked) -> LHsBind (GhcPass 'Typechecked)
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind) [(Id, LHsExpr (GhcPass 'Typechecked))]
rep_binds
tcg_env' :: TcGblEnv
tcg_env' = TcGblEnv
tcg_env TcGblEnv -> [LHsBinds (GhcPass 'Typechecked)] -> TcGblEnv
`addTypecheckedBinds` [[LHsBind (GhcPass 'Typechecked)] -> LHsBinds (GhcPass 'Typechecked)
forall a. [a] -> Bag a
listToBag [LHsBind (GhcPass 'Typechecked)]
binds]
(TcGblEnv, a) -> TcRn (TcGblEnv, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env', a
res)
getKindRep :: TypeableStuff -> CmEnv
-> Kind
-> KindRepM (LHsExpr GhcTc)
getKindRep :: TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
getKindRep stuff :: TypeableStuff
stuff@(Stuff {DynFlags
TyCon
DataCon
FastString -> LHsExpr (GhcPass 'Typechecked)
typeLitNatDataCon :: DataCon
typeLitSymbolDataCon :: DataCon
kindRepTypeLitSDataCon :: DataCon
kindRepTYPEDataCon :: DataCon
kindRepFunDataCon :: DataCon
kindRepAppDataCon :: DataCon
kindRepVarDataCon :: DataCon
kindRepTyConAppDataCon :: DataCon
kindRepTyCon :: TyCon
trNameLit :: FastString -> LHsExpr (GhcPass 'Typechecked)
trTyConDataCon :: DataCon
dflags :: DynFlags
typeLitNatDataCon :: 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
dflags :: TypeableStuff -> DynFlags
..}) CmEnv
in_scope = Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
go
where
go :: Kind -> KindRepM (LHsExpr GhcTc)
go :: Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
go = StateT KindRepEnv TcRn (LHsExpr (GhcPass 'Typechecked))
-> KindRepM (LHsExpr (GhcPass 'Typechecked))
forall a. StateT KindRepEnv TcRn a -> KindRepM a
KindRepM (StateT KindRepEnv TcRn (LHsExpr (GhcPass 'Typechecked))
-> KindRepM (LHsExpr (GhcPass 'Typechecked)))
-> (Type
-> StateT KindRepEnv TcRn (LHsExpr (GhcPass 'Typechecked)))
-> Type
-> KindRepM (LHsExpr (GhcPass 'Typechecked))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KindRepEnv
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsExpr (GhcPass 'Typechecked), KindRepEnv))
-> StateT KindRepEnv TcRn (LHsExpr (GhcPass 'Typechecked))
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((KindRepEnv
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsExpr (GhcPass 'Typechecked), KindRepEnv))
-> StateT KindRepEnv TcRn (LHsExpr (GhcPass 'Typechecked)))
-> (Type
-> KindRepEnv
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsExpr (GhcPass 'Typechecked), KindRepEnv))
-> Type
-> StateT KindRepEnv TcRn (LHsExpr (GhcPass 'Typechecked))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type
-> KindRepEnv
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsExpr (GhcPass 'Typechecked), KindRepEnv)
go'
go' :: Kind -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv)
go' :: Type
-> KindRepEnv
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsExpr (GhcPass 'Typechecked), KindRepEnv)
go' Type
k KindRepEnv
env
| Just Type
k' <- Type -> Maybe Type
tcView Type
k = Type
-> KindRepEnv
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsExpr (GhcPass 'Typechecked), KindRepEnv)
go' Type
k' KindRepEnv
env
| Just (Id
id, Maybe (LHsExpr (GhcPass 'Typechecked))
_) <- KindRepEnv
-> CmEnv
-> Type
-> Maybe (Id, Maybe (LHsExpr (GhcPass 'Typechecked)))
forall a. TypeMap a -> CmEnv -> Type -> Maybe a
lookupTypeMapWithScope KindRepEnv
env CmEnv
in_scope Type
k
= (LHsExpr (GhcPass 'Typechecked), KindRepEnv)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsExpr (GhcPass 'Typechecked), KindRepEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (IdP (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Id
IdP (GhcPass 'Typechecked)
id, KindRepEnv
env)
| Bool
otherwise
= do
Id
rep_bndr <- (Id -> InlinePragma -> Id
`setInlinePragma` InlinePragma
neverInlinePragma)
(Id -> Id) -> TcM Id -> TcM Id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FastString -> Type -> TcM Id
forall gbl lcl. FastString -> Type -> TcRnIf gbl lcl Id
newSysLocalId (String -> FastString
fsLit String
"$krep") (TyCon -> Type
mkTyConTy TyCon
kindRepTyCon)
(StateT KindRepEnv TcRn (LHsExpr (GhcPass 'Typechecked))
-> KindRepEnv
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsExpr (GhcPass 'Typechecked), KindRepEnv))
-> KindRepEnv
-> StateT KindRepEnv TcRn (LHsExpr (GhcPass 'Typechecked))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsExpr (GhcPass 'Typechecked), KindRepEnv)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT KindRepEnv TcRn (LHsExpr (GhcPass 'Typechecked))
-> KindRepEnv
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsExpr (GhcPass 'Typechecked), KindRepEnv)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT KindRepEnv
env (StateT KindRepEnv TcRn (LHsExpr (GhcPass 'Typechecked))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsExpr (GhcPass 'Typechecked), KindRepEnv))
-> StateT KindRepEnv TcRn (LHsExpr (GhcPass 'Typechecked))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsExpr (GhcPass 'Typechecked), KindRepEnv)
forall a b. (a -> b) -> a -> b
$ KindRepM (LHsExpr (GhcPass 'Typechecked))
-> StateT KindRepEnv TcRn (LHsExpr (GhcPass 'Typechecked))
forall a. KindRepM a -> StateT KindRepEnv TcRn a
unKindRepM (KindRepM (LHsExpr (GhcPass 'Typechecked))
-> StateT KindRepEnv TcRn (LHsExpr (GhcPass 'Typechecked)))
-> KindRepM (LHsExpr (GhcPass 'Typechecked))
-> StateT KindRepEnv TcRn (LHsExpr (GhcPass 'Typechecked))
forall a b. (a -> b) -> a -> b
$ do
LHsExpr (GhcPass 'Typechecked)
rhs <- TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
mkKindRepRhs TypeableStuff
stuff CmEnv
in_scope Type
k
CmEnv
-> Type -> Id -> LHsExpr (GhcPass 'Typechecked) -> KindRepM ()
addKindRepBind CmEnv
in_scope Type
k Id
rep_bndr LHsExpr (GhcPass 'Typechecked)
rhs
LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked)))
-> LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked))
forall a b. (a -> b) -> a -> b
$ IdP (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Id
IdP (GhcPass 'Typechecked)
rep_bndr
mkKindRepRhs :: TypeableStuff
-> CmEnv
-> Kind
-> KindRepM (LHsExpr GhcTc)
mkKindRepRhs :: TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
mkKindRepRhs stuff :: TypeableStuff
stuff@(Stuff {DynFlags
TyCon
DataCon
FastString -> LHsExpr (GhcPass 'Typechecked)
typeLitNatDataCon :: DataCon
typeLitSymbolDataCon :: DataCon
kindRepTypeLitSDataCon :: DataCon
kindRepTYPEDataCon :: DataCon
kindRepFunDataCon :: DataCon
kindRepAppDataCon :: DataCon
kindRepVarDataCon :: DataCon
kindRepTyConAppDataCon :: DataCon
kindRepTyCon :: TyCon
trNameLit :: FastString -> LHsExpr (GhcPass 'Typechecked)
trTyConDataCon :: DataCon
dflags :: DynFlags
typeLitNatDataCon :: 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
dflags :: TypeableStuff -> DynFlags
..}) CmEnv
in_scope = Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
new_kind_rep
where
new_kind_rep :: Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
new_kind_rep Type
k
| Bool -> Bool
not (Type -> Bool
tcIsConstraintKind Type
k)
, Just Type
arg <- HasDebugCallStack => Type -> Maybe Type
Type -> Maybe Type
kindRep_maybe Type
k
, Just (TyCon
tc, []) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
arg
, Just DataCon
dc <- TyCon -> Maybe DataCon
isPromotedDataCon_maybe TyCon
tc
= LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked)))
-> LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepTYPEDataCon LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
dc
new_kind_rep (TyVarTy Id
v)
| Just Arity
idx <- CmEnv -> Id -> Maybe Arity
lookupCME CmEnv
in_scope Id
v
= LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked)))
-> LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepVarDataCon
LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` Integer -> LHsExpr (GhcPass 'Typechecked)
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit (Arity -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Arity
idx)
| Bool
otherwise
= String -> SDoc -> KindRepM (LHsExpr (GhcPass 'Typechecked))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTyConKindRepBinds.go(tyvar)" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v)
new_kind_rep (AppTy Type
t1 Type
t2)
= do LHsExpr (GhcPass 'Typechecked)
rep1 <- TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
getKindRep TypeableStuff
stuff CmEnv
in_scope Type
t1
LHsExpr (GhcPass 'Typechecked)
rep2 <- TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
getKindRep TypeableStuff
stuff CmEnv
in_scope Type
t2
LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked)))
-> LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepAppDataCon
LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr (GhcPass 'Typechecked)
rep1 LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr (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 Id
rep_id <- TcM Id -> KindRepM Id
forall a. TcRn a -> KindRepM a
liftTc (TcM Id -> KindRepM Id) -> TcM Id -> KindRepM Id
forall a b. (a -> b) -> a -> b
$ Name -> TcM Id
forall (m :: * -> *). MonadThings m => Name -> m Id
lookupId Name
rep_name
[LHsExpr (GhcPass 'Typechecked)]
tys' <- (Type -> KindRepM (LHsExpr (GhcPass 'Typechecked)))
-> [Type] -> KindRepM [LHsExpr (GhcPass 'Typechecked)]
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
LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked)))
-> LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepTyConAppDataCon
LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` IdP (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Id
IdP (GhcPass 'Typechecked)
rep_id
LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` Type
-> [LHsExpr (GhcPass 'Typechecked)]
-> LHsExpr (GhcPass 'Typechecked)
mkList (TyCon -> Type
mkTyConTy TyCon
kindRepTyCon) [LHsExpr (GhcPass 'Typechecked)]
tys'
| Bool
otherwise
= String -> SDoc -> KindRepM (LHsExpr (GhcPass 'Typechecked))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTyConKindRepBinds(TyConApp)" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
k)
new_kind_rep (ForAllTy (Bndr Id
var ArgFlag
_) Type
ty)
= String -> SDoc -> KindRepM (LHsExpr (GhcPass 'Typechecked))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTyConKindRepBinds(ForAllTy)" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
var SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
new_kind_rep (FunTy AnonArgFlag
_ Type
t1 Type
t2)
= do LHsExpr (GhcPass 'Typechecked)
rep1 <- TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
getKindRep TypeableStuff
stuff CmEnv
in_scope Type
t1
LHsExpr (GhcPass 'Typechecked)
rep2 <- TypeableStuff
-> CmEnv -> Type -> KindRepM (LHsExpr (GhcPass 'Typechecked))
getKindRep TypeableStuff
stuff CmEnv
in_scope Type
t2
LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked)))
-> LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepFunDataCon
LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr (GhcPass 'Typechecked)
rep1 LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr (GhcPass 'Typechecked)
rep2
new_kind_rep (LitTy (NumTyLit Integer
n))
= LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked)))
-> LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepTypeLitSDataCon
LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
typeLitNatDataCon
LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (FastString -> HsLit (GhcPass 'Typechecked)
forall (p :: Pass). FastString -> HsLit (GhcPass p)
mkHsStringPrimLit (FastString -> HsLit (GhcPass 'Typechecked))
-> FastString -> HsLit (GhcPass 'Typechecked)
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show Integer
n)
new_kind_rep (LitTy (StrTyLit FastString
s))
= LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked)))
-> LHsExpr (GhcPass 'Typechecked)
-> KindRepM (LHsExpr (GhcPass 'Typechecked))
forall a b. (a -> b) -> a -> b
$ DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
kindRepTypeLitSDataCon
LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
typeLitSymbolDataCon
LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (FastString -> HsLit (GhcPass 'Typechecked)
forall (p :: Pass). FastString -> HsLit (GhcPass p)
mkHsStringPrimLit (FastString -> HsLit (GhcPass 'Typechecked))
-> FastString -> HsLit (GhcPass 'Typechecked)
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ FastString -> String
forall a. Show a => a -> String
show FastString
s)
new_kind_rep (CastTy Type
ty KindCoercion
co)
= String -> SDoc -> KindRepM (LHsExpr (GhcPass 'Typechecked))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTyConKindRepBinds.go(cast)" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
$$ KindCoercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr KindCoercion
co)
new_kind_rep (CoercionTy KindCoercion
co)
= String -> SDoc -> KindRepM (LHsExpr (GhcPass 'Typechecked))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkTyConKindRepBinds.go(coercion)" (KindCoercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr KindCoercion
co)
mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo
-> TyCon
-> LHsExpr GhcTc
-> LHsExpr GhcTc
mkTyConRepTyConRHS :: TypeableStuff
-> TypeRepTodo
-> TyCon
-> LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked)
mkTyConRepTyConRHS (Stuff {DynFlags
TyCon
DataCon
FastString -> LHsExpr (GhcPass 'Typechecked)
typeLitNatDataCon :: DataCon
typeLitSymbolDataCon :: DataCon
kindRepTypeLitSDataCon :: DataCon
kindRepTYPEDataCon :: DataCon
kindRepFunDataCon :: DataCon
kindRepAppDataCon :: DataCon
kindRepVarDataCon :: DataCon
kindRepTyConAppDataCon :: DataCon
kindRepTyCon :: TyCon
trNameLit :: FastString -> LHsExpr (GhcPass 'Typechecked)
trTyConDataCon :: DataCon
dflags :: DynFlags
typeLitNatDataCon :: 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
dflags :: TypeableStuff -> DynFlags
..}) TypeRepTodo
todo TyCon
tycon LHsExpr (GhcPass 'Typechecked)
kind_rep
= DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
trTyConDataCon
LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (DynFlags -> Word64 -> HsLit (GhcPass 'Typechecked)
word64 DynFlags
dflags Word64
high)
LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (DynFlags -> Word64 -> HsLit (GhcPass 'Typechecked)
word64 DynFlags
dflags Word64
low)
LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` TypeRepTodo -> LHsExpr (GhcPass 'Typechecked)
mod_rep_expr TypeRepTodo
todo
LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` FastString -> LHsExpr (GhcPass 'Typechecked)
trNameLit (String -> FastString
mkFastString String
tycon_str)
LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (Arity -> HsLit (GhcPass 'Typechecked)
int Arity
n_kind_vars)
LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr (GhcPass 'Typechecked)
kind_rep
where
n_kind_vars :: Arity
n_kind_vars = [TyConBinder] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length ([TyConBinder] -> Arity) -> [TyConBinder] -> Arity
forall a b. (a -> b) -> a -> b
$ (TyConBinder -> Bool) -> [TyConBinder] -> [TyConBinder]
forall a. (a -> Bool) -> [a] -> [a]
filter TyConBinder -> Bool
isNamedTyConBinder (TyCon -> [TyConBinder]
tyConBinders TyCon
tycon)
tycon_str :: String
tycon_str = String -> String
add_tick (OccName -> String
occNameString (TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName TyCon
tycon))
add_tick :: String -> String
add_tick String
s | TyCon -> Bool
isPromotedDataCon TyCon
tycon = Char
'\'' Char -> String -> String
forall a. a -> [a] -> [a]
: String
s
| Bool
otherwise = String
s
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 :: Arity -> HsLit (GhcPass 'Typechecked)
int Arity
n = XHsIntPrim (GhcPass 'Typechecked)
-> Integer -> HsLit (GhcPass 'Typechecked)
forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim (String -> SourceText
SourceText (String -> SourceText) -> String -> SourceText
forall a b. (a -> b) -> a -> b
$ Arity -> String
forall a. Show a => a -> String
show Arity
n) (Arity -> Integer
forall a. Integral a => a -> Integer
toInteger Arity
n)
word64 :: DynFlags -> Word64 -> HsLit GhcTc
word64 :: DynFlags -> Word64 -> HsLit (GhcPass 'Typechecked)
word64 DynFlags
dflags Word64
n
| DynFlags -> Arity
wORD_SIZE DynFlags
dflags Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
4 = XHsWord64Prim (GhcPass 'Typechecked)
-> Integer -> HsLit (GhcPass 'Typechecked)
forall x. XHsWord64Prim x -> Integer -> HsLit x
HsWord64Prim SourceText
XHsWord64Prim (GhcPass 'Typechecked)
NoSourceText (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
n)
| Bool
otherwise = XHsWordPrim (GhcPass 'Typechecked)
-> Integer -> HsLit (GhcPass 'Typechecked)
forall x. XHsWordPrim x -> Integer -> HsLit x
HsWordPrim SourceText
XHsWordPrim (GhcPass 'Typechecked)
NoSourceText (Word64 -> Integer
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 = (LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked))
-> LHsExpr (GhcPass 'Typechecked)
-> [LHsExpr (GhcPass 'Typechecked)]
-> LHsExpr (GhcPass 'Typechecked)
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 LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr (GhcPass 'Typechecked)
x LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (id :: Pass).
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)
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
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)
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap ([Type] -> HsWrapper
mkWpTyApps [Type
ty]) (DataCon -> LHsExpr (GhcPass 'Typechecked)
nlHsDataCon DataCon
consDataCon)