module TcTypeable(mkTypeableBinds) where
import TcBinds( addTypecheckedBinds )
import IfaceEnv( newGlobalBinder )
import TcEnv
import TcRnMonad
import PrelNames
import TysPrim ( primTyCons )
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 FastString ( FastString, mkFastString )
import Data.Word( Word64 )
mkTypeableBinds :: TcM TcGblEnv
mkTypeableBinds
= do {
; tcg_env <- mkModIdBindings
; tcg_env <- setGblEnv tcg_env mkPrimTypeableBinds
; setGblEnv tcg_env $
let tycons = filter needs_typeable_binds (tcg_tcs tcg_env)
in mkTypeableTyConBinds tycons
}
where
needs_typeable_binds tc =
(not (isFamInstTyCon tc) && 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 Id)
mkModIdRHS mod
= do { trModuleDataCon <- tcLookupDataCon trModuleDataConName
; trNameLit <- mkTrNameLit
; return $ nlHsApps (dataConWrapId trModuleDataCon)
[ trNameLit (unitIdFS (moduleUnitId mod))
, trNameLit (moduleNameFS (moduleName mod)) ]
}
mkTypeableTyConBinds :: [TyCon] -> TcM TcGblEnv
mkTypeableTyConBinds tycons
= do { gbl_env <- getGblEnv
; mod <- getModule
; let mod_expr = case tcg_tr_module gbl_env of
Just mod_id -> nlHsVar mod_id
Nothing -> pprPanic "tcMkTypeableBinds" (ppr tycons)
; stuff <- collect_stuff mod mod_expr
; let 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 { 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
; stuff <- collect_stuff gHC_PRIM (nlHsVar ghc_prim_module_id)
; let prim_binds :: LHsBinds Id
prim_binds = unitBag ghc_prim_module_bind
`unionBags` ghcPrimTypeableBinds stuff
prim_rep_ids = collectHsBindsBinders prim_binds
; gbl_env <- tcExtendGlobalValEnv prim_rep_ids getGblEnv
; return (gbl_env `addTypecheckedBinds` [prim_binds])
}
else getGblEnv
}
where
ghcPrimTypeableBinds :: TypeableStuff -> LHsBinds Id
ghcPrimTypeableBinds stuff
= unionManyBags (map mkBind all_prim_tys)
where
all_prim_tys :: [TyCon]
all_prim_tys = [ tc' | tc <- funTyCon : primTyCons
, tc' <- tc : tyConATs tc ]
mkBind :: TyCon -> LHsBinds Id
mkBind = mk_typeable_binds stuff
data TypeableStuff
= Stuff { dflags :: DynFlags
, mod_rep :: LHsExpr Id
, pkg_str :: String
, mod_str :: String
, trTyConTyCon :: TyCon
, trTyConDataCon :: DataCon
, trNameLit :: FastString -> LHsExpr Id
}
collect_stuff :: Module -> LHsExpr Id -> TcM TypeableStuff
collect_stuff mod mod_rep = do
dflags <- getDynFlags
let pkg_str = unitIdString (moduleUnitId mod)
mod_str = moduleNameString (moduleName mod)
trTyConTyCon <- tcLookupTyCon trTyConTyConName
trTyConDataCon <- tcLookupDataCon trTyConDataConName
trNameLit <- mkTrNameLit
return Stuff {..}
mkTrNameLit :: TcM (FastString -> LHsExpr Id)
mkTrNameLit = do
trNameSDataCon <- tcLookupDataCon trNameSDataConName
let trNameLit :: FastString -> LHsExpr Id
trNameLit fs = nlHsApps (dataConWrapId trNameSDataCon)
[nlHsLit (mkHsStringPrimLit fs)]
return trNameLit
mk_typeable_binds :: TypeableStuff -> TyCon -> LHsBinds Id
mk_typeable_binds stuff tycon
= mkTyConRepBinds stuff tycon
`unionBags`
unionManyBags (map (mkTyConRepBinds stuff . promoteDataCon)
(tyConDataCons tycon))
mkTyConRepBinds :: TypeableStuff -> TyCon -> LHsBinds Id
mkTyConRepBinds stuff@(Stuff {..}) tycon
= case tyConRepName_maybe tycon of
Just rep_name -> unitBag (mkVarBind rep_id rep_rhs)
where
rep_id = mkExportedVanillaId rep_name (mkTyConTy trTyConTyCon)
rep_rhs = mkTyConRepRHS stuff tycon
_ -> emptyBag
mkTyConRepRHS :: TypeableStuff -> TyCon -> LHsExpr Id
mkTyConRepRHS (Stuff {..}) tycon = rep_rhs
where
rep_rhs = nlHsApps (dataConWrapId trTyConDataCon)
[ nlHsLit (word64 high), nlHsLit (word64 low)
, mod_rep
, 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)