module TcTypeable(mkTypeableBinds) where
import GhcPrelude
import BasicTypes ( Boxity(..), neverInlinePragma, SourceText(..) )
import TcBinds( addTypecheckedBinds )
import IfaceEnv( newGlobalBinder )
import TyCoRep( Type(..), TyLit(..) )
import TcEnv
import TcEvidence ( mkWpTyApps )
import TcRnMonad
import HscTypes ( lookupId )
import PrelNames
import TysPrim ( primTyCons )
import TysWiredIn ( tupleTyCon, sumTyCon, runtimeRepTyCon
, vecCountTyCon, vecElemTyCon
, nilDataCon, consDataCon )
import Name
import Id
import Type
import Kind ( isTYPEApp )
import TyCon
import DataCon
import Name ( getOccName )
import Module
import HsSyn
import DynFlags
import Bag
import Var ( TyVarBndr(..) )
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
= do {
; tcg_env <- mkModIdBindings
; (tcg_env, prim_todos) <- setGblEnv tcg_env mkPrimTypeableTodos
; setGblEnv tcg_env $
do { mod <- getModule
; let tycons = filter needs_typeable_binds (tcg_tcs tcg_env)
mod_id = case tcg_tr_module tcg_env of
Just mod_id -> mod_id
Nothing -> pprPanic "tcMkTypeableBinds" (ppr tycons)
; traceTc "mkTypeableBinds" (ppr tycons)
; this_mod_todos <- todoForTyCons mod mod_id tycons
; mkTypeRepTodoBinds (this_mod_todos : prim_todos)
} }
where
needs_typeable_binds tc
| tc `elem` [runtimeRepTyCon, vecCountTyCon, vecElemTyCon]
= False
| otherwise =
isAlgTyCon tc
|| isDataFamilyTyCon tc
|| isClassTyCon tc
mkModIdBindings :: TcM TcGblEnv
mkModIdBindings
= do { mod <- getModule
; loc <- getSrcSpanM
; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc
; trModuleTyCon <- tcLookupTyCon trModuleTyConName
; let mod_id = mkExportedVanillaId mod_nm (mkTyConApp trModuleTyCon [])
; mod_bind <- mkVarBind mod_id <$> mkModIdRHS mod
; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv
; return (tcg_env { tcg_tr_module = Just mod_id }
`addTypecheckedBinds` [unitBag mod_bind]) }
mkModIdRHS :: Module -> TcM (LHsExpr GhcTc)
mkModIdRHS mod
= do { trModuleDataCon <- tcLookupDataCon trModuleDataConName
; trNameLit <- mkTrNameLit
; return $ nlHsDataCon trModuleDataCon
`nlHsApp` trNameLit (unitIdFS (moduleUnitId mod))
`nlHsApp` trNameLit (moduleNameFS (moduleName mod))
}
data TypeableTyCon
= TypeableTyCon
{ tycon :: !TyCon
, tycon_rep_id :: !Id
}
data TypeRepTodo
= TypeRepTodo
{ mod_rep_expr :: LHsExpr GhcTc
, pkg_fingerprint :: !Fingerprint
, mod_fingerprint :: !Fingerprint
, todo_tycons :: [TypeableTyCon]
}
| ExportedKindRepsTodo [(Kind, Id)]
todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo
todoForTyCons mod mod_id tycons = do
trTyConTy <- mkTyConTy <$> tcLookupTyCon trTyConTyConName
let mk_rep_id :: TyConRepName -> Id
mk_rep_id rep_name = mkExportedVanillaId rep_name trTyConTy
let typeable_tycons :: [TypeableTyCon]
typeable_tycons =
[ TypeableTyCon { tycon = tc''
, tycon_rep_id = mk_rep_id rep_name
}
| tc <- tycons
, tc' <- tc : tyConATs tc
, let promoted = map promoteDataCon (tyConDataCons tc')
, tc'' <- tc' : promoted
, not $ isFamInstTyCon tc''
, Just rep_name <- pure $ tyConRepName_maybe tc''
, typeIsTypeable $ dropForAlls $ tyConKind tc''
]
return TypeRepTodo { mod_rep_expr = nlHsVar mod_id
, pkg_fingerprint = pkg_fpr
, mod_fingerprint = mod_fpr
, todo_tycons = typeable_tycons
}
where
mod_fpr = fingerprintString $ moduleNameString $ moduleName mod
pkg_fpr = fingerprintString $ unitIdString $ moduleUnitId mod
todoForExportedKindReps :: [(Kind, Name)] -> TcM TypeRepTodo
todoForExportedKindReps kinds = do
trKindRepTy <- mkTyConTy <$> tcLookupTyCon kindRepTyConName
let mkId (k, name) = (k, mkExportedVanillaId name trKindRepTy)
return $ ExportedKindRepsTodo $ map mkId kinds
mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv
mkTypeRepTodoBinds [] = getGblEnv
mkTypeRepTodoBinds todos
= do { stuff <- collect_stuff
; let produced_bndrs :: [Id]
produced_bndrs = [ tycon_rep_id
| todo@(TypeRepTodo{}) <- todos
, TypeableTyCon {..} <- todo_tycons todo
] ++
[ rep_id
| ExportedKindRepsTodo kinds <- todos
, (_, rep_id) <- kinds
]
; gbl_env <- tcExtendGlobalValEnv produced_bndrs getGblEnv
; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds GhcTc]
mk_binds todo@(TypeRepTodo {}) =
mapM (mkTyConRepBinds stuff todo) (todo_tycons todo)
mk_binds (ExportedKindRepsTodo kinds) =
mkExportedKindReps stuff kinds >> return []
; (gbl_env, binds) <- setGblEnv gbl_env
$ runKindRepM (mapM mk_binds todos)
; return $ gbl_env `addTypecheckedBinds` concat binds }
mkPrimTypeableTodos :: TcM (TcGblEnv, [TypeRepTodo])
mkPrimTypeableTodos
= do { mod <- getModule
; if mod == gHC_TYPES
then do {
trModuleTyCon <- tcLookupTyCon trModuleTyConName
; let ghc_prim_module_id =
mkExportedVanillaId trGhcPrimModuleName
(mkTyConTy trModuleTyCon)
; ghc_prim_module_bind <- mkVarBind ghc_prim_module_id
<$> mkModIdRHS gHC_PRIM
; gbl_env <- tcExtendGlobalValEnv [ghc_prim_module_id]
getGblEnv
; let gbl_env' = gbl_env `addTypecheckedBinds`
[unitBag ghc_prim_module_bind]
; todo1 <- todoForExportedKindReps builtInKindReps
; todo2 <- todoForTyCons gHC_PRIM ghc_prim_module_id
ghcPrimTypeableTyCons
; return ( gbl_env' , [todo1, todo2])
}
else do gbl_env <- getGblEnv
return (gbl_env, [])
}
ghcPrimTypeableTyCons :: [TyCon]
ghcPrimTypeableTyCons = concat
[ [ runtimeRepTyCon, vecCountTyCon, vecElemTyCon, funTyCon ]
, map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE]
, map sumTyCon [2..mAX_SUM_SIZE]
, primTyCons
]
data TypeableStuff
= Stuff { dflags :: DynFlags
, trTyConDataCon :: DataCon
, trNameLit :: FastString -> LHsExpr GhcTc
, kindRepTyCon :: TyCon
, kindRepTyConAppDataCon :: DataCon
, kindRepVarDataCon :: DataCon
, kindRepAppDataCon :: DataCon
, kindRepFunDataCon :: DataCon
, kindRepTYPEDataCon :: DataCon
, kindRepTypeLitSDataCon :: DataCon
, typeLitSymbolDataCon :: DataCon
, typeLitNatDataCon :: DataCon
}
collect_stuff :: TcM TypeableStuff
collect_stuff = do
dflags <- getDynFlags
trTyConDataCon <- tcLookupDataCon trTyConDataConName
kindRepTyCon <- tcLookupTyCon kindRepTyConName
kindRepTyConAppDataCon <- tcLookupDataCon kindRepTyConAppDataConName
kindRepVarDataCon <- tcLookupDataCon kindRepVarDataConName
kindRepAppDataCon <- tcLookupDataCon kindRepAppDataConName
kindRepFunDataCon <- tcLookupDataCon kindRepFunDataConName
kindRepTYPEDataCon <- tcLookupDataCon kindRepTYPEDataConName
kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName
typeLitSymbolDataCon <- tcLookupDataCon typeLitSymbolDataConName
typeLitNatDataCon <- tcLookupDataCon typeLitNatDataConName
trNameLit <- mkTrNameLit
return Stuff {..}
mkTrNameLit :: TcM (FastString -> LHsExpr GhcTc)
mkTrNameLit = do
trNameSDataCon <- tcLookupDataCon trNameSDataConName
let trNameLit :: FastString -> LHsExpr GhcTc
trNameLit fs = nlHsPar $ nlHsDataCon trNameSDataCon
`nlHsApp` nlHsLit (mkHsStringPrimLit fs)
return trNameLit
mkTyConRepBinds :: TypeableStuff -> TypeRepTodo
-> TypeableTyCon -> KindRepM (LHsBinds GhcTc)
mkTyConRepBinds stuff@(Stuff {..}) todo (TypeableTyCon {..})
= do
let (bndrs, kind) = splitForAllTyVarBndrs (tyConKind tycon)
liftTc $ traceTc "mkTyConKindRepBinds"
(ppr tycon $$ ppr (tyConKind tycon) $$ ppr kind)
let ctx = mkDeBruijnContext (map binderVar bndrs)
kind_rep <- getKindRep stuff ctx kind
let tycon_rep_rhs = mkTyConRepTyConRHS stuff todo tycon kind_rep
tycon_rep_bind = mkVarBind tycon_rep_id tycon_rep_rhs
return $ unitBag tycon_rep_bind
tyConIsTypeable :: TyCon -> Bool
tyConIsTypeable tc =
isJust (tyConRepName_maybe tc)
&& typeIsTypeable (dropForAlls $ tyConKind tc)
typeIsTypeable :: Type -> Bool
typeIsTypeable ty
| Just ty' <- coreView ty = typeIsTypeable ty'
typeIsTypeable ty
| Just _ <- isTYPEApp ty = True
typeIsTypeable (TyVarTy _) = True
typeIsTypeable (AppTy a b) = typeIsTypeable a && typeIsTypeable b
typeIsTypeable (FunTy a b) = typeIsTypeable a && typeIsTypeable b
typeIsTypeable (TyConApp tc args) = tyConIsTypeable tc
&& all typeIsTypeable args
typeIsTypeable (ForAllTy{}) = False
typeIsTypeable (LitTy _) = True
typeIsTypeable (CastTy{}) = False
typeIsTypeable (CoercionTy{}) = False
type KindRepEnv = TypeMap (Id, Maybe (LHsExpr GhcTc))
newtype KindRepM a = KindRepM { unKindRepM :: StateT KindRepEnv TcRn a }
deriving (Functor, Applicative, Monad)
liftTc :: TcRn a -> KindRepM a
liftTc = KindRepM . lift
builtInKindReps :: [(Kind, Name)]
builtInKindReps =
[ (star, starKindRepName)
, (mkFunTy star star, starArrStarKindRepName)
, (mkFunTys [star, star] star, starArrStarArrStarKindRepName)
]
where
star = liftedTypeKind
initialKindRepEnv :: TcRn KindRepEnv
initialKindRepEnv = foldlM add_kind_rep emptyTypeMap builtInKindReps
where
add_kind_rep acc (k,n) = do
id <- tcLookupId n
return $! extendTypeMap acc k (id, Nothing)
mkExportedKindReps :: TypeableStuff
-> [(Kind, Id)]
-> KindRepM ()
mkExportedKindReps stuff@(Stuff {..}) = mapM_ kindrep_binding
where
empty_scope = mkDeBruijnContext []
kindrep_binding :: (Kind, Id) -> KindRepM ()
kindrep_binding (kind, rep_bndr) = do
rhs <- mkKindRepRhs stuff empty_scope kind
addKindRepBind empty_scope kind rep_bndr rhs
addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr GhcTc -> KindRepM ()
addKindRepBind in_scope k bndr rhs =
KindRepM $ modify' $
\env -> extendTypeMapWithScope env in_scope k (bndr, Just rhs)
runKindRepM :: KindRepM a -> TcRn (TcGblEnv, a)
runKindRepM (KindRepM action) = do
kindRepEnv <- initialKindRepEnv
(res, reps_env) <- runStateT action kindRepEnv
let rep_binds = foldTypeMap to_bind_pair [] reps_env
to_bind_pair (bndr, Just rhs) rest = (bndr, rhs) : rest
to_bind_pair (_, Nothing) rest = rest
tcg_env <- tcExtendGlobalValEnv (map fst rep_binds) getGblEnv
let binds = map (uncurry mkVarBind) rep_binds
tcg_env' = tcg_env `addTypecheckedBinds` [listToBag binds]
return (tcg_env', res)
getKindRep :: TypeableStuff -> CmEnv
-> Kind
-> KindRepM (LHsExpr GhcTc)
getKindRep stuff@(Stuff {..}) in_scope = go
where
go :: Kind -> KindRepM (LHsExpr GhcTc)
go = KindRepM . StateT . go'
go' :: Kind -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv)
go' k env
| Just k' <- tcView k = go' k' env
| Just (id, _) <- lookupTypeMapWithScope env in_scope k
= return (nlHsVar id, env)
| otherwise
= do
rep_bndr <- (`setInlinePragma` neverInlinePragma)
<$> newSysLocalId (fsLit "$krep") (mkTyConTy kindRepTyCon)
flip runStateT env $ unKindRepM $ do
rhs <- mkKindRepRhs stuff in_scope k
addKindRepBind in_scope k rep_bndr rhs
return $ nlHsVar rep_bndr
mkKindRepRhs :: TypeableStuff
-> CmEnv
-> Kind
-> KindRepM (LHsExpr GhcTc)
mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep
where
new_kind_rep k
| Just rr <- isTYPEApp k
= return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon rr
new_kind_rep (TyVarTy v)
| Just idx <- lookupCME in_scope v
= return $ nlHsDataCon kindRepVarDataCon
`nlHsApp` nlHsIntLit (fromIntegral idx)
| otherwise
= pprPanic "mkTyConKindRepBinds.go(tyvar)" (ppr v)
new_kind_rep (AppTy t1 t2)
= do rep1 <- getKindRep stuff in_scope t1
rep2 <- getKindRep stuff in_scope t2
return $ nlHsDataCon kindRepAppDataCon
`nlHsApp` rep1 `nlHsApp` rep2
new_kind_rep k@(TyConApp tc tys)
| Just rep_name <- tyConRepName_maybe tc
= do rep_id <- liftTc $ lookupId rep_name
tys' <- mapM (getKindRep stuff in_scope) tys
return $ nlHsDataCon kindRepTyConAppDataCon
`nlHsApp` nlHsVar rep_id
`nlHsApp` mkList (mkTyConTy kindRepTyCon) tys'
| otherwise
= pprPanic "mkTyConKindRepBinds(TyConApp)" (ppr tc $$ ppr k)
new_kind_rep (ForAllTy (TvBndr var _) ty)
= pprPanic "mkTyConKindRepBinds(ForAllTy)" (ppr var $$ ppr ty)
new_kind_rep (FunTy t1 t2)
= do rep1 <- getKindRep stuff in_scope t1
rep2 <- getKindRep stuff in_scope t2
return $ nlHsDataCon kindRepFunDataCon
`nlHsApp` rep1 `nlHsApp` rep2
new_kind_rep (LitTy (NumTyLit n))
= return $ nlHsDataCon kindRepTypeLitSDataCon
`nlHsApp` nlHsDataCon typeLitNatDataCon
`nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show n)
new_kind_rep (LitTy (StrTyLit s))
= return $ nlHsDataCon kindRepTypeLitSDataCon
`nlHsApp` nlHsDataCon typeLitSymbolDataCon
`nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show s)
new_kind_rep (CastTy ty co)
= pprPanic "mkTyConKindRepBinds.go(cast)" (ppr ty $$ ppr co)
new_kind_rep (CoercionTy co)
= pprPanic "mkTyConKindRepBinds.go(coercion)" (ppr co)
mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo
-> TyCon
-> LHsExpr GhcTc
-> LHsExpr GhcTc
mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep
= nlHsDataCon trTyConDataCon
`nlHsApp` nlHsLit (word64 dflags high)
`nlHsApp` nlHsLit (word64 dflags low)
`nlHsApp` mod_rep_expr todo
`nlHsApp` trNameLit (mkFastString tycon_str)
`nlHsApp` nlHsLit (int n_kind_vars)
`nlHsApp` kind_rep
where
n_kind_vars = length $ filter isNamedTyConBinder (tyConBinders tycon)
tycon_str = add_tick (occNameString (getOccName tycon))
add_tick s | isPromotedDataCon tycon = '\'' : s
| otherwise = s
Fingerprint high low = fingerprintFingerprints [ pkg_fingerprint todo
, mod_fingerprint todo
, fingerprintString tycon_str
]
int :: Int -> HsLit GhcTc
int n = HsIntPrim (SourceText $ show n) (toInteger n)
word64 :: DynFlags -> Word64 -> HsLit GhcTc
word64 dflags n
| wORD_SIZE dflags == 4 = HsWord64Prim NoSourceText (toInteger n)
| otherwise = HsWordPrim NoSourceText (toInteger n)
mkList :: Type -> [LHsExpr GhcTc] -> LHsExpr GhcTc
mkList ty = foldr consApp (nilExpr ty)
where
cons = consExpr ty
consApp :: LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
consApp x xs = cons `nlHsApp` x `nlHsApp` xs
nilExpr :: Type -> LHsExpr GhcTc
nilExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon nilDataCon)
consExpr :: Type -> LHsExpr GhcTc
consExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon consDataCon)