import RnMonad
import ErrUtils ( ErrMsg )
import Name ( Name, OccName(..), Provenance(..), ExportFlag(..), NamedThing(..),
- occNameFlavour, getSrcLoc,
+ occNameFlavour, getSrcLoc, occNameString,
NameSet, emptyNameSet, addListToNameSet, nameSetToList,
mkLocalName, mkGlobalName, modAndOcc,
nameOccName, setNameProvenance, isVarOcc, getNameProvenance,
import Outputable
import Util ( removeDups )
import List ( nub )
+import Char ( isAlphanum )
\end{code}
-- When renaming derived definitions we are in *interface* mode (because we can trip
-- over original names), but we still want to make the Dfun locally-defined.
-- So we can't use whether or not we're in source mode to decide the locally-defined question.
-newDfunName :: Maybe RdrName -> SrcLoc -> RnMS s Name
-newDfunName Nothing src_loc -- Local instance decls have a "Nothing"
+newDfunName :: OccName -> OccName -> Maybe RdrName -> SrcLoc -> RnMS s Name
+newDfunName _ _ (Just n) src_loc -- Imported ones have "Just n"
= getModuleRn `thenRn` \ mod_name ->
- newInstUniq `thenRn` \ inst_uniq ->
+ newImportedGlobalName mod_name (rdrNameOcc n) HiFile {- Correct? -}
+newDfunName cl_nm tycon_nm Nothing src_loc -- Local instance decls have a "Nothing"
+ = getModuleRn `thenRn` \ mod_name ->
+ newInstUniq name `thenRn` \ inst_uniq ->
let
- dfun_occ = VarOcc (_PK_ ("$d" ++ show inst_uniq))
+ dfun_occ = VarOcc (_PK_ ("$d" ++ (_UNPK_ name) ++ show inst_uniq))
in
newLocallyDefinedGlobalName mod_name dfun_occ
(\_ -> Exported) src_loc
+ where
+ {-
+ Dictionary names have the following form
-newDfunName (Just n) src_loc -- Imported ones have "Just n"
- = getModuleRn `thenRn` \ mod_name ->
- newImportedGlobalName mod_name (rdrNameOcc n) HiFile {- Correct? -}
+ $d<class><tycon><n>
+
+ where "n" is a positive number, and "tycon" is the
+ name of the type constructor for which a "class"
+ instance is derived.
+
+ Prefixing dictionary names with their class and instance
+ types improves the behaviour of the recompilation checker.
+ (fewer recompilations required should an instance or type
+ declaration be added to a module.)
+ -}
+ -- We're dropping the modids on purpose.
+ tycon_nm_str = occNameString tycon_nm
+ cl_nm_str = occNameString cl_nm
+
+ -- give up on any type constructor that starts with a
+ -- non-alphanumeric char (e.g., [] (,*)
+ name
+ | (_NULL_ tycon_nm_str) || not (isAlphanum (_HEAD_ (tycon_nm_str))) = cl_nm_str
+ | otherwise = cl_nm_str _APPEND_ tycon_nm_str
newLocalNames :: [(RdrName,SrcLoc)] -> RnM s d [Name]
\begin{code}
loadInterface :: SDoc -> Module -> IfaceFlavour -> RnMG Ifaces
loadInterface doc_str load_mod as_source
- = getIfacesRn `thenRn` \ ifaces ->
- let
+ = getIfacesRn `thenRn` \ ifaces ->
+ let
Ifaces this_mod mod_map decls
all_names imp_names (insts, tycls_names)
deferred_data_decls inst_mods = ifaces
- in
+ in
-- CHECK WHETHER WE HAVE IT ALREADY
- case lookupFM mod_map load_mod of {
+ case lookupFM mod_map load_mod of {
Just (hif, _, _, _) | hif `as_good_as` as_source
-> -- Already in the cache; don't re-read it
returnRn ifaces ;
other ->
-- READ THE MODULE IN
- findAndReadIface doc_str load_mod as_source `thenRn` \ read_result ->
- case read_result of {
+ findAndReadIface doc_str load_mod as_source `thenRn` \ read_result ->
+ case read_result of {
-- Check for not found
Nothing -> -- Not found, so add an empty export env to the Ifaces map
-- so that we don't look again
failWithRn Nothing (cannaeReadFile file_path err)
\end{code}
-mkSearchPath takes a string consisting of a colon-separated list
+%*********************************************************
+%* *
+\subsection{Utils}
+%* *
+%*********************************************************
+
+@mkSearchPath@ takes a string consisting of a colon-separated list
of directories and corresponding suffixes, and turns it into a list
of (directory, suffix) pairs. For example:
import SrcLoc ( SrcLoc, mkGeneratedSrcLoc )
import Unique ( Unique )
import UniqFM ( UniqFM )
-import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM )
+import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM )
import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )
import UniqSet
import UniqSupply
-- Common part
data RnDown s = RnDown
SrcLoc
- (SSTRef s RnNameSupply)
+ (SSTRef s (GenRnNameSupply s))
(SSTRef s (Bag WarnMsg, Bag ErrMsg))
(SSTRef s ([Occurrence],[Occurrence])) -- Occurrences: compulsory and optional resp
===================================================
\begin{code}
-type RnNameSupply = (UniqSupply, Int, FiniteMap (Module,OccName) Name)
+type RnNameSupply = GenRnNameSupply RealWorld
+
+type GenRnNameSupply s
+ = ( UniqSupply
+ , FiniteMap FAST_STRING (SSTRef s Int)
+ , FiniteMap (Module,OccName) Name
+ )
-- Ensures that one (m,n) pair gets one unique
- -- The Int is used to give a number to each instance declaration;
- -- it's really a separate name supply.
+ -- The finite map on FAST_STRINGS is used to give a per-class unique to each
+ -- instance declaration; it's really a separate name supply.
data RnEnv = RnEnv GlobalNameEnv FixityEnv
emptyRnEnv = RnEnv emptyNameEnv emptyFixityEnv
initRn mod us dirs loc do_rn
= sstToIO $
- newMutVarSST (us, 1, builtins) `thenSST` \ names_var ->
- newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
- newMutVarSST (emptyIfaces mod) `thenSST` \ iface_var ->
- newMutVarSST initOccs `thenSST` \ occs_var ->
+ newMutVarSST (us, emptyFM, builtins) `thenSST` \ names_var ->
+ newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
+ newMutVarSST (emptyIfaces mod) `thenSST` \ iface_var ->
+ newMutVarSST initOccs `thenSST` \ occs_var ->
let
rn_down = RnDown loc names_var errs_var occs_var
g_down = GDown dirs iface_var
\begin{code}
renameSourceCode :: Module
- -> RnNameSupply
+ -> RnNameSupply
-> RnMS RealWorld r
-> r
================ Name supply =====================
\begin{code}
-getNameSupplyRn :: RnM s d RnNameSupply
+getNameSupplyRn :: RnM s d (GenRnNameSupply s)
getNameSupplyRn (RnDown loc names_var errs_var occs_var) l_down
= readMutVarSST names_var
-setNameSupplyRn :: RnNameSupply -> RnM s d ()
+setNameSupplyRn :: GenRnNameSupply s -> RnM s d ()
setNameSupplyRn names' (RnDown loc names_var errs_var occs_var) l_down
= writeMutVarSST names_var names'
--- The "instance-decl unique supply", inst, is just an integer that's used to
--- give a unique number for each instance declaration.
-newInstUniq :: RnM s d Int
-newInstUniq (RnDown loc names_var errs_var occs_var) l_down
- = readMutVarSST names_var `thenSST` \ (us, inst, cache) ->
- writeMutVarSST names_var (us, inst+1, cache) `thenSST_`
- returnSST inst
+-- The "instance-decl unique supply", inst, is really a map from class names
+-- to unique supplies. Having per-class unique numbers for instance decls helps
+-- the recompilation checker.
+newInstUniq :: FAST_STRING -> RnM s d Int
+newInstUniq cname (RnDown loc names_var errs_var occs_var) l_down
+ = readMutVarSST names_var `thenSST` \ (us, mapInst, cache) ->
+ case lookupFM mapInst cname of
+ Just class_us ->
+ readMutVarSST class_us `thenSST` \ v ->
+ writeMutVarSST class_us (v+1) `thenSST_`
+ returnSST v
+ Nothing -> -- first time caller gets to add a unique supply
+ -- to the finite map for that class.
+ newMutVarSST 1 `thenSST` \ class_us ->
+ let
+ mapInst' = addToFM mapInst cname class_us
+ in
+ writeMutVarSST names_var (us, mapInst', cache) `thenSST_`
+ returnSST 0
+
\end{code}
================ Occurrences =====================
import Name ( Name, OccName(..), occNameString, prefixOccName,
ExportFlag(..), Provenance(..), NameSet,
- elemNameSet
+ elemNameSet, nameOccName, NamedThing(..)
)
import FiniteMap ( lookupFM )
import Id ( GenId{-instance NamedThing-} )
checkDupNames meth_doc meth_names `thenRn_`
rnMethodBinds mbinds `thenRn` \ mbinds' ->
mapRn rn_uprag uprags `thenRn` \ new_uprags ->
-
- newDfunName maybe_dfun src_loc `thenRn` \ dfun_name ->
- addOccurrenceName dfun_name `thenRn_`
+
+ let
+ -- We use the class name and the name of the first
+ -- type constructor the class is applied to.
+ (cl_nm, tycon_nm) = mkDictPrefix inst_ty'
+
+ mkDictPrefix (MonoDictTy cl tys) =
+ case tys of
+ [] -> (c_nm, nilOccName )
+ (ty:_) -> (c_nm, getInstHeadTy ty)
+ where
+ c_nm = nameOccName (getName cl)
+
+ mkDictPrefix (HsPreForAllTy _ ty) = mkDictPrefix ty
+ mkDictPrefix (HsForAllTy _ _ ty) = mkDictPrefix ty -- can this
+ mkDictPrefix _ = (nilOccName, nilOccName)
+
+ getInstHeadTy t
+ = case t of
+ MonoTyVar tv -> nameOccName (getName tv)
+ MonoTyApp t _ -> getInstHeadTy t
+ _ -> nilOccName
+ -- I cannot see how the rest of HsType constructors
+ -- can occur, but this isn't really a failure condition,
+ -- so we return silently.
+
+ nilOccName = (VarOcc _NIL_) -- ToDo: add OccName constructor fun for this.
+ in
+ newDfunName cl_nm tycon_nm maybe_dfun src_loc `thenRn` \ dfun_name ->
+ addOccurrenceName dfun_name `thenRn_`
-- The dfun is not optional, because we use its version number
-- to identify the version of the instance declaration
import PrelInfo ( needsDataDeclCtxtClassKeys )
import Maybes ( maybeToBool )
import Name ( isLocallyDefined, getSrcLoc, Provenance,
- Name{--O only-}, Module, NamedThing(..)
+ Name{--O only-}, Module, NamedThing(..),
+ OccName, nameOccName
)
import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
mapRn rn_one method_binds_s `thenRn` \ dfun_names_w_method_binds ->
returnRn (dfun_names_w_method_binds, rn_extra_binds)
)
- rn_one meth_binds = newDfunName Nothing mkGeneratedSrcLoc `thenRn` \ dfun_name ->
- rnMethodBinds meth_binds `thenRn` \ rn_meth_binds ->
- returnRn (dfun_name, rn_meth_binds)
+ rn_one (cl_nm, tycon_nm, meth_binds)
+ = newDfunName cl_nm tycon_nm
+ Nothing mkGeneratedSrcLoc `thenRn` \ dfun_name ->
+ rnMethodBinds meth_binds `thenRn` \ rn_meth_binds ->
+ returnRn (dfun_name, rn_meth_binds)
really_new_inst_infos = map (gen_inst_info modname)
(new_inst_infos `zip` dfun_names_w_method_binds)
\begin{code}
-- Generate the method bindings for the required instance
-gen_bind :: InstInfo -> RdrNameMonoBinds
+-- (paired with class name, as we need that when generating dict
+-- names.)
+gen_bind :: InstInfo -> ({-class-}OccName, {-tyCon-}OccName, RdrNameMonoBinds)
gen_bind (InstInfo clas _ [ty] _ _ _ _ _ _)
| not from_here
- = EmptyMonoBinds
+ = (clas_nm, tycon_nm, EmptyMonoBinds)
| otherwise
- = assoc "gen_inst_info:bad derived class"
- [(eqClassKey, gen_Eq_binds)
- ,(ordClassKey, gen_Ord_binds)
- ,(enumClassKey, gen_Enum_binds)
- ,(evalClassKey, gen_Eval_binds)
- ,(boundedClassKey, gen_Bounded_binds)
- ,(showClassKey, gen_Show_binds)
- ,(readClassKey, gen_Read_binds)
- ,(ixClassKey, gen_Ix_binds)
- ]
- (classKey clas)
- tycon
+ = (clas_nm, tycon_nm,
+ assoc "gen_bind:bad derived class"
+ [(eqClassKey, gen_Eq_binds)
+ ,(ordClassKey, gen_Ord_binds)
+ ,(enumClassKey, gen_Enum_binds)
+ ,(evalClassKey, gen_Eval_binds)
+ ,(boundedClassKey, gen_Bounded_binds)
+ ,(showClassKey, gen_Show_binds)
+ ,(readClassKey, gen_Read_binds)
+ ,(ixClassKey, gen_Ix_binds)
+ ]
+ (classKey clas)
+ tycon)
where
+ clas_nm = nameOccName (getName clas)
+ tycon_nm = nameOccName (getName tycon)
from_here = isLocallyDefined tycon
(tycon,_,_) = splitAlgTyConApp ty
projects / ghc-hetmet.git / commitdiff