module TcTypeable(
mkTypeableBinds, mkModIdBindings
) where
import TcBinds( addTypecheckedBinds )
import IfaceEnv( newGlobalBinder )
import TcEnv
import TcRnMonad
import PrelNames( gHC_TYPES, trModuleDataConName, trTyConDataConName, trNameSDataConName )
import Id
import IdInfo( IdDetails(..) )
import Type
import TyCon
import DataCon
import Name( getOccName )
import OccName
import Module
import HsSyn
import DynFlags
import Bag
import Fingerprint(Fingerprint(..), fingerprintString)
import Outputable
import Data.Word( Word64 )
import FastString ( FastString, mkFastString )
mkModIdBindings :: TcM TcGblEnv
mkModIdBindings
= do { mod <- getModule
; if mod == gHC_TYPES
then getGblEnv
else
do { loc <- getSrcSpanM
; tr_mod_dc <- tcLookupDataCon trModuleDataConName
; tr_name_dc <- tcLookupDataCon trNameSDataConName
; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc
; let mod_id = mkExportedLocalId ReflectionId mod_nm
(mkTyConApp (dataConTyCon tr_mod_dc) [])
mod_bind = mkVarBind mod_id mod_rhs
mod_rhs = nlHsApps (dataConWrapId tr_mod_dc)
[ trNameLit tr_name_dc (unitIdFS (moduleUnitId mod))
, trNameLit tr_name_dc (moduleNameFS (moduleName mod)) ]
; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv
; return (tcg_env { tcg_tr_module = Just mod_id }
`addTypecheckedBinds` [unitBag mod_bind]) } }
mkTypeableBinds :: [TyCon] -> TcM TcGblEnv
mkTypeableBinds tycons
= do { dflags <- getDynFlags
; gbl_env <- getGblEnv
; mod <- getModule
; if mod == gHC_TYPES
then return gbl_env
else
do { tr_datacon <- tcLookupDataCon trTyConDataConName
; trn_datacon <- tcLookupDataCon trNameSDataConName
; let pkg_str = unitIdString (moduleUnitId mod)
mod_str = moduleNameString (moduleName mod)
mod_expr = case tcg_tr_module gbl_env of
Just mod_id -> nlHsVar mod_id
Nothing -> pprPanic "tcMkTypeableBinds" (ppr tycons)
stuff = (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon)
all_tycons = [ tc' | tc <- tycons, tc' <- tc : tyConATs tc ]
tc_binds = map (mk_typeable_binds stuff) all_tycons
tycon_rep_ids = foldr ((++) . collectHsBindsBinders) [] tc_binds
; gbl_env <- tcExtendGlobalValEnv tycon_rep_ids getGblEnv
; return (gbl_env `addTypecheckedBinds` tc_binds) } }
trNameLit :: DataCon -> FastString -> LHsExpr Id
trNameLit tr_name_dc fs
= nlHsApps (dataConWrapId tr_name_dc) [nlHsLit (mkHsStringPrimLit fs)]
type TypeableStuff
= ( DynFlags
, LHsExpr Id
, String
, String
, DataCon
, DataCon )
mk_typeable_binds :: TypeableStuff -> TyCon -> LHsBinds Id
mk_typeable_binds stuff tycon
= mkTyConRepBinds stuff tycon
`unionBags`
unionManyBags (map (mkTypeableDataConBinds stuff) (tyConDataCons tycon))
mkTyConRepBinds :: TypeableStuff -> TyCon -> LHsBinds Id
mkTyConRepBinds (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon) tycon
= case tyConRepName_maybe tycon of
Just rep_name -> unitBag (mkVarBind rep_id rep_rhs)
where
rep_id = mkExportedLocalId ReflectionId rep_name (mkTyConApp tr_tycon [])
_ -> emptyBag
where
tr_tycon = dataConTyCon tr_datacon
rep_rhs = nlHsApps (dataConWrapId tr_datacon)
[ nlHsLit (word64 high), nlHsLit (word64 low)
, mod_expr
, trNameLit trn_datacon (mkFastString tycon_str) ]
tycon_str = add_tick (occNameString (getOccName tycon))
add_tick s | isPromotedDataCon tycon = '\'' : s
| otherwise = s
hashThis :: String
hashThis = unwords [pkg_str, mod_str, tycon_str]
Fingerprint high low = fingerprintString hashThis
word64 :: Word64 -> HsLit
word64 | wORD_SIZE dflags == 4 = \n -> HsWord64Prim (show n) (toInteger n)
| otherwise = \n -> HsWordPrim (show n) (toInteger n)
mkTypeableDataConBinds :: TypeableStuff -> DataCon -> LHsBinds Id
mkTypeableDataConBinds stuff dc
= mkTyConRepBinds stuff (promoteDataCon dc)