opt_WarnUnusedBinds, opt_WarnUnusedImports )
import HsSyn
import RdrHsSyn ( RdrName(..), RdrNameIE,
- rdrNameOcc, ieOcc, isQual, qual
+ rdrNameOcc, isQual, qual, isClassDataConRdrName
)
import HsTypes ( getTyVarName, replaceTyVarName )
-import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..), pprModule )
+import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..) )
import RnMonad
+import ErrUtils ( ErrMsg )
import Name ( Name, OccName(..), Provenance(..), ExportFlag(..), NamedThing(..),
- occNameString, occNameFlavour, getSrcLoc,
+ occNameFlavour, getSrcLoc, occNameString,
NameSet, emptyNameSet, addListToNameSet, nameSetToList,
mkLocalName, mkGlobalName, modAndOcc,
nameOccName, setNameProvenance, isVarOcc, getNameProvenance,
- pprProvenance, pprOccName, pprModule, pprNameProvenance,
- isLocalName
+ pprOccName, isLocalName
)
import TyCon ( TyCon )
-import TysWiredIn ( tupleTyCon, listTyCon, charTyCon, intTyCon )
+import TysWiredIn ( tupleTyCon, listTyCon, charTyCon )
import FiniteMap
import Unique ( Unique, Uniquable(..), unboundKey )
import UniqFM ( listToUFM, plusUFM_C )
-import Maybes ( maybeToBool )
import UniqSupply
import SrcLoc ( SrcLoc, noSrcLoc )
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]
Looking up a name in the RnEnv.
\begin{code}
-lookupRn :: RdrName
- -> Maybe Name -- Result of environment lookup
- -> RnMS s Name
-
-lookupRn rdr_name (Just name)
- = -- Found the name in the envt
- returnRn name -- In interface mode the only things in
- -- the environment are things in local (nested) scopes
-
-lookupRn rdr_name Nothing
- = -- We didn't find the name in the environment
- getModeRn `thenRn` \ mode ->
- case mode of {
- SourceMode -> failWithRn (mkUnboundName rdr_name)
- (unknownNameErr rdr_name) ;
- -- Souurce mode; lookup failure is an error
+checkUnboundRn :: RdrName -> Maybe Name -> RnMS s Name
+checkUnboundRn rdr_name (Just name)
+ = -- Found it!
+ returnRn name
+
+checkUnboundRn rdr_name Nothing
+ = -- Not found by lookup
+ getModeRn `thenRn` \ mode ->
+ case mode of
+ -- Not found when processing source code; so fail
+ SourceMode -> failWithRn (mkUnboundName rdr_name)
+ (unknownNameErr rdr_name)
+
+ -- Not found when processing an imported declaration,
+ -- so we create a new name for the purpose
+ InterfaceMode _ _ ->
+ case rdr_name of
+ Qual mod_name occ hif -> newImportedGlobalName mod_name occ hif
+
+ -- An Unqual is allowed; interface files contain
+ -- unqualified names for locally-defined things, such as
+ -- constructors of a data type.
+ Unqual occ -> getModuleRn `thenRn ` \ mod_name ->
+ newImportedGlobalName mod_name occ HiFile
- InterfaceMode _ _ ->
-
-
- ----------------------------------------------------
- -- OK, so we're in interface mode
- -- An Unqual is allowed; interface files contain
- -- unqualified names for locally-defined things, such as
- -- constructors of a data type.
- -- So, qualify the unqualified name with the
- -- module of the interface file, and try again
- case rdr_name of
- Unqual occ -> getModuleRn `thenRn` \ mod ->
- newImportedGlobalName mod occ HiFile
- Qual mod occ hif -> newImportedGlobalName mod occ hif
-
- }
lookupBndrRn rdr_name
= lookupNameRn rdr_name `thenRn` \ maybe_name ->
- lookupRn rdr_name maybe_name `thenRn` \ name ->
+ checkUnboundRn rdr_name maybe_name `thenRn` \ name ->
if isLocalName name then
returnRn name
lookupOccRn :: RdrName -> RnMS s Name
lookupOccRn rdr_name
= lookupNameRn rdr_name `thenRn` \ maybe_name ->
- lookupRn rdr_name maybe_name `thenRn` \ name ->
+ checkUnboundRn rdr_name maybe_name `thenRn` \ name ->
let
name' = mungePrintUnqual rdr_name name
in
addOccurrenceName name'
-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
--- environment only. It's used for record field names only.
+-- environment. It's used only for
+-- record field names
+-- class op names in class and instance decls
lookupGlobalOccRn :: RdrName -> RnMS s Name
lookupGlobalOccRn rdr_name
= lookupGlobalNameRn rdr_name `thenRn` \ maybe_name ->
- lookupRn rdr_name maybe_name `thenRn` \ name ->
+ checkUnboundRn rdr_name maybe_name `thenRn` \ name ->
let
name' = mungePrintUnqual rdr_name name
in
addOccurrenceName name'
+
-- mungePrintUnqual is used to make *imported* *occurrences* print unqualified
-- if they were mentioned unqualified in the source code.
-- This improves error messages from the type checker.
\begin{code}
plusGlobalNameEnvRn :: GlobalNameEnv -> GlobalNameEnv -> RnM s d GlobalNameEnv
plusGlobalNameEnvRn env1 env2
- = mapRn (addErrRn.nameClashErr) (conflictsFM conflicting_name env1 env2) `thenRn_`
+ = mapRn addNameClashErrRn (conflictsFM conflicting_name env1 env2) `thenRn_`
returnRn (env1 `plusFM` env2)
addOneToGlobalNameEnv :: GlobalNameEnv -> RdrName -> (Name, HowInScope) -> RnM s d GlobalNameEnv
addOneToGlobalNameEnv env rdr_name name
= case lookupFM env rdr_name of
Just name2 | conflicting_name name name2
- -> addErrRn (nameClashErr (rdr_name, (name, name2))) `thenRn_`
+ -> addNameClashErrRn (rdr_name, (name, name2)) `thenRn_`
returnRn env
other -> returnRn (addToFM env rdr_name name)
filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
| sub_names_ok = AvailTC n (filter is_wanted ns)
- | otherwise = pprTrace "filterAvail" (hsep [ppr ie, pprAvail avail]) $
+ | otherwise =
+#ifdef DEBUG
+ pprTrace "filterAvail" (hsep [ppr ie, pprAvail avail]) $
+#endif
NotAvailable
where
is_wanted name = nameOccName name `elem` wanted_occs
unusedNameWarn name = quotes (ppr name) <+> ptext SLIT("is bound but not used")
-nameClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
- = hang (hsep [ptext SLIT("Conflicting definitions for"), quotes (ppr rdr_name)])
- 4 (vcat [ppr how_in_scope1,
- ppr how_in_scope2])
+addNameClashErrRn (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
+ | isClassDataConRdrName rdr_name
+ -- Nasty hack to prevent error messages complain about conflicts for ":C",
+ -- where "C" is a class. There'll be a message about C, and :C isn't
+ -- the programmer's business. There may be a better way to filter this
+ -- out, but I couldn't get up the energy to find it.
+ = returnRn ()
+
+ | otherwise
+ = addErrRn (hang (hsep [ptext SLIT("Conflicting definitions for"), quotes (ppr rdr_name)])
+ 4 (vcat [ppr how_in_scope1,
+ ppr how_in_scope2]))
fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
= hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)])
projects / ghc-hetmet.git / blobdiff