module TcTypeable(
mkTypeableBinds, mkPrimTypeableBinds, mkModIdBindings
) where
import TcBinds( addTypecheckedBinds )
import IfaceEnv( newGlobalBinder )
import TcEnv
import TcRnMonad
import PrelNames
import TysPrim ( primTyCons )
import TysWiredIn ( trModuleTyCon, trModuleDataCon, trTyConTyCon
, trTyConDataCon, trNameSDataCon )
import Id
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
; loc <- getSrcSpanM
; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc
; 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 -> LHsExpr Id
mkModIdRHS mod
= nlHsApps (dataConWrapId trModuleDataCon)
[ trNameLit (unitIdFS (moduleUnitId mod))
, trNameLit (moduleNameFS (moduleName mod)) ]
mkTypeableBinds :: [TyCon] -> TcM TcGblEnv
mkTypeableBinds tycons
= do { dflags <- getDynFlags
; gbl_env <- getGblEnv
; mod <- getModule
; 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)
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) }
mkPrimTypeableBinds :: TcM TcGblEnv
mkPrimTypeableBinds
= do { dflags <- getDynFlags
; mod <- getModule
; let prim_binds :: LHsBinds Id
prim_binds
| mod == gHC_TYPES = ghcPrimTypeableBinds dflags
| otherwise = emptyBag
prim_rep_ids = collectHsBindsBinders prim_binds
; gbl_env <- tcExtendGlobalValEnv prim_rep_ids getGblEnv
; return (gbl_env `addTypecheckedBinds` [prim_binds]) }
ghcPrimTypeableBinds :: DynFlags -> LHsBinds Id
ghcPrimTypeableBinds dflags
= ghc_prim_module_bind `unionBags` unionManyBags (map mkBind all_prim_tys)
where
all_prim_tys :: [TyCon]
all_prim_tys = [ tc' | tc <- funTyCon : primTyCons
, tc' <- tc : tyConATs tc ]
ghc_prim_module_id =
mkExportedVanillaId trGhcPrimModuleName (mkTyConTy trModuleTyCon)
ghc_prim_module_bind =
unitBag $ mkVarBind ghc_prim_module_id (mkModIdRHS gHC_PRIM)
stuff :: TypeableStuff
stuff = (dflags, nlHsVar ghc_prim_module_id, "ghc-prim", "GHC.Prim")
mkBind :: TyCon -> LHsBinds Id
mkBind = mk_typeable_binds stuff
trNameLit :: FastString -> LHsExpr Id
trNameLit fs
= nlHsApps (dataConWrapId trNameSDataCon) [nlHsLit (mkHsStringPrimLit fs)]
type TypeableStuff
= ( DynFlags
, LHsExpr Id
, String
, String
)
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 stuff tycon
= case tyConRepName_maybe tycon of
Just rep_name -> unitBag (mkVarBind rep_id rep_rhs)
where
rep_id = mkExportedVanillaId rep_name (mkTyConApp trTyConTyCon [])
rep_rhs = mkTyConRepRHS stuff tycon
_ -> emptyBag
mkTypeableDataConBinds :: TypeableStuff -> DataCon -> LHsBinds Id
mkTypeableDataConBinds stuff dc
= mkTyConRepBinds stuff (promoteDataCon dc)
mkTyConRepRHS :: TypeableStuff -> TyCon -> LHsExpr Id
mkTyConRepRHS (dflags, mod_expr, pkg_str, mod_str) tycon = rep_rhs
where
rep_rhs = nlHsApps (dataConWrapId trTyConDataCon)
[ nlHsLit (word64 high), nlHsLit (word64 low)
, mod_expr
, trNameLit (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)