import Util
import Unique
import BasicTypes
-import StaticFlags
import UniqFM
import UniqSet
import FastString
\begin{code}
-- | Derive a name for the representation type constructor of a
-- @data@\/@newtype@ instance.
-mkInstTyTcOcc :: Int -- ^ DFun Index
- -> OccName -- ^ Family name, e.g. @Map@
- -> OccName -- ^ Nice unique version, e.g. @:R23Map@
-mkInstTyTcOcc index occ
- = mk_deriv tcName ("R" ++ show index ++ ":") (occNameString occ)
+mkInstTyTcOcc :: String -- ^ Family name, e.g. @Map@
+ -> OccSet -- ^ avoid these Occs
+ -> OccName -- ^ @R:Map@
+mkInstTyTcOcc str set =
+ chooseUniqueOcc tcName ('R' : ':' : str) set
\end{code}
\begin{code}
mkDFunOcc :: String -- ^ Typically the class and type glommed together e.g. @OrdMaybe@.
-- Only used in debug mode, for extra clarity
-> Bool -- ^ Is this a hs-boot instance DFun?
- -> Int -- ^ Unique index
+ -> OccSet -- ^ avoid these Occs
-> OccName -- ^ E.g. @$f3OrdMaybe@
-- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real
-- thing when we compile the mother module. Reason: we don't know exactly
-- what the mother module will call it.
-mkDFunOcc info_str is_boot index
- = mk_deriv VarName prefix string
+mkDFunOcc info_str is_boot set
+ = chooseUniqueOcc VarName (prefix ++ info_str) set
where
prefix | is_boot = "$fx"
| otherwise = "$f"
- string | opt_PprStyle_Debug = show index ++ info_str
- | otherwise = show index
+\end{code}
+
+Sometimes we need to pick an OccName that has not already been used,
+given a set of in-use OccNames.
+
+\begin{code}
+chooseUniqueOcc :: NameSpace -> String -> OccSet -> OccName
+chooseUniqueOcc ns str set = loop (mkOccName ns str) (0::Int)
+ where
+ loop occ n
+ | occ `elemOccSet` set = loop (mkOccName ns (str ++ show n)) (n+1)
+ | otherwise = occ
\end{code}
We used to add a '$m' to indicate a method, but that gives rise to bad
\begin{code}
newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
-newDFunName clas (ty:_) loc
- = do { index <- nextDFunIndex
- ; is_boot <- tcIsHsBoot
+newDFunName clas tys loc
+ = do { is_boot <- tcIsHsBoot
; mod <- getModule
; let info_string = occNameString (getOccName clas) ++
- occNameString (getDFunTyKey ty)
- dfun_occ = mkDFunOcc info_string is_boot index
-
+ concatMap (occNameString.getDFunTyKey) tys
+ ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)
; newGlobalBinder mod dfun_occ loc }
-
-newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
\end{code}
Make a name for the representation tycon of a family instance. It's an
newGlobalBinder.
\begin{code}
-newFamInstTyConName :: Name -> SrcSpan -> TcM Name
-newFamInstTyConName tc_name loc
- = do { index <- nextDFunIndex
- ; mod <- getModule
- ; let occ = nameOccName tc_name
- ; newGlobalBinder mod (mkInstTyTcOcc index occ) loc }
+newFamInstTyConName :: Name -> [Type] -> SrcSpan -> TcM Name
+newFamInstTyConName tc_name tys loc
+ = do { mod <- getModule
+ ; let info_string = occNameString (getOccName tc_name) ++
+ concatMap (occNameString.getDFunTyKey) tys
+ ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
+ ; newGlobalBinder mod occ loc }
\end{code}
Stable names used for foreign exports and annotations.
keep_var <- newIORef emptyNameSet ;
used_rdrnames_var <- newIORef Set.empty ;
th_var <- newIORef False ;
- dfun_n_var <- newIORef 1 ;
+ dfun_n_var <- newIORef emptyOccSet ;
type_env_var <- case hsc_type_env_var hsc_env of {
Just (_mod, te_var) -> return te_var ;
Nothing -> newIORef emptyNameEnv } ;
%************************************************************************
\begin{code}
-nextDFunIndex :: TcM Int -- Get the next dfun index
-nextDFunIndex = do { env <- getGblEnv
- ; let dfun_n_var = tcg_dfun_n env
- ; n <- readMutVar dfun_n_var
- ; writeMutVar dfun_n_var (n+1)
- ; return n }
+chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
+chooseUniqueOccTc fn =
+ do { env <- getGblEnv
+ ; let dfun_n_var = tcg_dfun_n env
+ ; set <- readMutVar dfun_n_var
+ ; let occ = fn set
+ ; writeMutVar dfun_n_var (extendOccSet set occ)
+ ; return occ
+ }
getLIEVar :: TcM (TcRef LIE)
getLIEVar = do { env <- getLclEnv; return (tcl_lie env) }
-- reference is implicit rather than explicit, so we have to zap a
-- mutable variable.
- tcg_dfun_n :: TcRef Int,
- -- ^ Allows us to number off the names of DFuns.
- --
- -- It's convenient to allocate an External Name for a DFun, with
- -- a permanently-fixed unique, just like other top-level functions
- -- defined in this module. But that means we need a canonical
- -- occurrence name, distinct from all other dfuns in this module,
- -- and this name supply serves that purpose (df1, df2, etc).
+ tcg_dfun_n :: TcRef OccSet,
+ -- ^ Allows us to choose unique DFun names.
-- The next fields accumulate the payload of the module
-- The binds, rules and foreign-decl fiels are collected
; checkValidTypeInst t_typats t_rhs
-- (4) construct representation tycon
- ; rep_tc_name <- newFamInstTyConName tc_name loc
+ ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs)
(typeKind t_rhs) (Just (family, t_typats))
}}
newtypeConError tc_name (length k_cons)
-- (4) construct representation tycon
- ; rep_tc_name <- newFamInstTyConName tc_name loc
+ ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
; let ex_ok = True -- Existentials ok for type families!
; fixM (\ rep_tycon -> do
{ let orig_res_ty = mkTyConApp fam_tycon t_typats
projects / ghc-hetmet.git / commitdiff