From: simonpj Date: Mon, 20 Dec 1999 10:34:37 +0000 (+0000) Subject: [project @ 1999-12-20 10:34:27 by simonpj] X-Git-Tag: Approximately_9120_patches~5371 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=e921b2e307532e0f30eefa88b11a124be592bde4;p=ghc-hetmet.git [project @ 1999-12-20 10:34:27 by simonpj] This commit implements a substantial re-organisation of the Prelude It also fixes a couple of small renamer bugs that were reported recently (notably, Sven pointed out that we weren't reporting unused imports properly) My original goal was to get rid of all "orphan" modules (i.e. ones with instance decls that don't belong either to a tycon or a class defined in the same module). This should reduce the number of interface files that have to be read when compiling small Haskell modules. But like most expeditions into the Prelude Swamp, it spiraled out of control. The result is quite satisfactory, though. GONE AWAY: PrelCCall, PrelNumExtra NEW: PrelReal, PrelFloat, PrelByteArr, PrelNum.hi-boot (The extra PrelNum.hi-boot is because of a tiresome thin-air Id, addr2Integer, which used to be in PrelBase.) Quite a lot of types have moved from one module to another, which entails some changes to part of the compiler (PrelInfo, PrelMods) etc, and there are a few places in the RTS includes and even in the driver that know about these home modules (alas). So the rough structure is as follows, in (linearised) dependency order [this list now appears in PrelBase.lhs] PrelGHC Has no implementation. It defines built-in things, and by importing it you bring them into scope. The source file is PrelGHC.hi-boot, which is just copied to make PrelGHC.hi Classes: CCallable, CReturnable PrelBase Classes: Eq, Ord, Functor, Monad Types: list, (), Int, Bool, Ordering, Char, String PrelTup Types: tuples, plus instances for PrelBase classes PrelShow Class: Show, plus instances for PrelBase/PrelTup types PrelEnum Class: Enum, plus instances for PrelBase/PrelTup types PrelMaybe Type: Maybe, plus instances for PrelBase classes PrelNum Class: Num, plus instances for Int Type: Integer, plus instances for all classes so far (Eq, Ord, Num, Show) Integer is needed here because it is mentioned in the signature of 'fromInteger' in class Num PrelReal Classes: Real, Integral, Fractional, RealFrac plus instances for Int, Integer Types: Ratio, Rational plus intances for classes so far Rational is needed here because it is mentioned in the signature of 'toRational' in class Real Ix Classes: Ix, plus instances for Int, Bool, Char, Integer, Ordering, tuples PrelArr Types: Array, MutableArray, MutableVar Does *not* contain any ByteArray stuff (see PrelByteArr) Arrays are used by a function in PrelFloat PrelFloat Classes: Floating, RealFloat Types: Float, Double, plus instances of all classes so far This module contains everything to do with floating point. It is a big module (900 lines) With a bit of luck, many modules can be compiled without ever reading PrelFloat.hi PrelByteArr Types: ByteArray, MutableByteArray We want this one to be after PrelFloat, because it defines arrays of unboxed floats. Other Prelude modules are much easier with fewer complex dependencies. --- diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 4a3bfaa..46e0a01 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -21,7 +21,7 @@ module Name ( tidyTopName, nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule, - isUserExportedName, nameSrcLoc, + isUserExportedName, isUserImportedExplicitlyName, nameSrcLoc, isLocallyDefinedName, isSystemName, isLocalName, isGlobalName, isExternallyVisibleName, @@ -398,6 +398,9 @@ nameRdrName (Name { n_sort = sort, n_occ = occ }) = mkRdrQual (moduleName (name isUserExportedName (Name { n_prov = LocalDef _ Exported }) = True isUserExportedName other = False +isUserImportedExplicitlyName (Name { n_prov = NonLocalDef (UserImport _ _ explicit) _ }) = explicit +isUserImportedExplicitlyName other = False + nameSrcLoc name = provSrcLoc (n_prov name) provSrcLoc (LocalDef loc _) = loc diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 224e31e..81aff83 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -466,7 +466,7 @@ ifaceBinds hdl needed_ids final_ids binds %************************************************************************ \begin{code} -ifaceTyCons hdl tycons = hPutCol hdl upp_tycon (sortLt (<) (filter (for_iface_name . getName) tycons )) +ifaceTyCons hdl tycons = hPutCol hdl upp_tycon (sortLt (<) (filter (for_iface_name . getName) tycons)) ifaceClasses hdl classes = hPutCol hdl upp_class (sortLt (<) (filter (for_iface_name . getName) classes)) for_iface_name name = isLocallyDefined name && diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index b52682f..58a3d8f 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -26,7 +26,7 @@ module PrelInfo ( maybeCharLikeCon, maybeIntLikeCon, needsDataDeclCtxtClassKeys, cCallishClassKeys, cCallishTyKeys, isNoDictClass, isNumericClass, isStandardClass, isCcallishClass, - isCreturnableClass, numericTyKeys, + isCreturnableClass, numericTyKeys, fractionalClassKeys, -- RdrNames for lots of things, mainly used in derivings eq_RDR, ne_RDR, le_RDR, lt_RDR, ge_RDR, gt_RDR, max_RDR, min_RDR, @@ -319,12 +319,13 @@ ioDataCon_RDR = dataQual pREL_IO_BASE_Name SLIT("IO") bindIO_RDR = varQual pREL_IO_BASE_Name SLIT("bindIO") orderingTyCon_RDR = tcQual pREL_BASE_Name SLIT("Ordering") -rationalTyCon_RDR = tcQual pREL_NUM_Name SLIT("Rational") -ratioTyCon_RDR = tcQual pREL_NUM_Name SLIT("Ratio") -ratioDataCon_RDR = dataQual pREL_NUM_Name SLIT(":%") -byteArrayTyCon_RDR = tcQual pREL_ARR_Name SLIT("ByteArray") -mutableByteArrayTyCon_RDR = tcQual pREL_ARR_Name SLIT("MutableByteArray") +rationalTyCon_RDR = tcQual pREL_REAL_Name SLIT("Rational") +ratioTyCon_RDR = tcQual pREL_REAL_Name SLIT("Ratio") +ratioDataCon_RDR = dataQual pREL_REAL_Name SLIT(":%") + +byteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("ByteArray") +mutableByteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("MutableByteArray") foreignObjTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("ForeignObj") stablePtrTyCon_RDR = tcQual pREL_STABLE_Name SLIT("StablePtr") @@ -401,13 +402,14 @@ plus_RDR = varQual pREL_NUM_Name SLIT("+") times_RDR = varQual pREL_NUM_Name SLIT("*") -- Other numberic classes -realClass_RDR = clsQual pREL_NUM_Name SLIT("Real") -integralClass_RDR = clsQual pREL_NUM_Name SLIT("Integral") -fractionalClass_RDR = clsQual pREL_NUM_Name SLIT("Fractional") -floatingClass_RDR = clsQual pREL_NUM_Name SLIT("Floating") -realFracClass_RDR = clsQual pREL_NUM_Name SLIT("RealFrac") -realFloatClass_RDR = clsQual pREL_NUM_Name SLIT("RealFloat") -fromRational_RDR = varQual pREL_NUM_Name SLIT("fromRational") +realClass_RDR = clsQual pREL_REAL_Name SLIT("Real") +integralClass_RDR = clsQual pREL_REAL_Name SLIT("Integral") +realFracClass_RDR = clsQual pREL_REAL_Name SLIT("RealFrac") +fractionalClass_RDR = clsQual pREL_REAL_Name SLIT("Fractional") +fromRational_RDR = varQual pREL_REAL_Name SLIT("fromRational") + +floatingClass_RDR = clsQual pREL_FLOAT_Name SLIT("Floating") +realFloatClass_RDR = clsQual pREL_FLOAT_Name SLIT("RealFloat") -- Class Ix ixClass_RDR = clsQual iX_Name SLIT("Ix") @@ -549,6 +551,7 @@ because the list of ambiguous dictionaries hasn't been simplified. isCcallishClass, isCreturnableClass, isNoDictClass, isNumericClass, isStandardClass :: Class -> Bool +isFractionalClass clas = classKey clas `is_elem` fractionalClassKeys isNumericClass clas = classKey clas `is_elem` numericClassKeys isStandardClass clas = classKey clas `is_elem` standardClassKeys isCcallishClass clas = classKey clas `is_elem` cCallishClassKeys @@ -560,7 +563,11 @@ numericClassKeys = [ numClassKey , realClassKey , integralClassKey - , fractionalClassKey + ] + ++ fractionalClassKeys + +fractionalClassKeys = + [ fractionalClassKey , floatingClassKey , realFracClassKey , realFloatClassKey diff --git a/ghc/compiler/prelude/PrelMods.lhs b/ghc/compiler/prelude/PrelMods.lhs index 5e77ba9..bb9943d 100644 --- a/ghc/compiler/prelude/PrelMods.lhs +++ b/ghc/compiler/prelude/PrelMods.lhs @@ -15,15 +15,16 @@ module PrelMods mkTupNameStr, mkUbxTupNameStr, pREL_GHC, pREL_BASE, pREL_ADDR, pREL_STABLE, - pREL_IO_BASE, pREL_PACK, pREL_ERR, + pREL_IO_BASE, pREL_PACK, pREL_ERR, pREL_NUM, pREL_FLOAT, pREL_REAL, pREL_GHC_Name, pRELUDE_Name, mONAD_Name, rATIO_Name, iX_Name, mAIN_Name, pREL_MAIN_Name, pREL_ERR_Name, pREL_BASE_Name, pREL_NUM_Name, pREL_LIST_Name, pREL_TUP_Name, pREL_ADDR_Name, pREL_READ_Name, pREL_PACK_Name, pREL_CONC_Name, pREL_IO_BASE_Name, - pREL_ST_Name, pREL_ARR_Name, pREL_FOREIGN_Name, - pREL_STABLE_Name, pREL_SHOW_Name, pREL_ENUM_Name, iNT_Name, wORD_Name + pREL_ST_Name, pREL_ARR_Name, pREL_BYTEARR_Name, pREL_FOREIGN_Name, + pREL_STABLE_Name, pREL_SHOW_Name, pREL_ENUM_Name, iNT_Name, wORD_Name, + pREL_REAL_Name, pREL_FLOAT_Name ) where #include "HsVersions.h" @@ -48,10 +49,13 @@ pREL_CONC_Name = mkSrcModule "PrelConc" pREL_IO_BASE_Name = mkSrcModule "PrelIOBase" pREL_ST_Name = mkSrcModule "PrelST" pREL_ARR_Name = mkSrcModule "PrelArr" +pREL_BYTEARR_Name = mkSrcModule "PrelByteArr" pREL_FOREIGN_Name = mkSrcModule "PrelForeign" pREL_STABLE_Name = mkSrcModule "PrelStable" pREL_ADDR_Name = mkSrcModule "PrelAddr" pREL_ERR_Name = mkSrcModule "PrelErr" +pREL_REAL_Name = mkSrcModule "PrelReal" +pREL_FLOAT_Name = mkSrcModule "PrelFloat" mONAD_Name = mkSrcModule "Monad" rATIO_Name = mkSrcModule "Ratio" @@ -68,6 +72,9 @@ pREL_STABLE = mkPrelModule pREL_STABLE_Name pREL_IO_BASE = mkPrelModule pREL_IO_BASE_Name pREL_PACK = mkPrelModule pREL_PACK_Name pREL_ERR = mkPrelModule pREL_ERR_Name +pREL_NUM = mkPrelModule pREL_NUM_Name +pREL_REAL = mkPrelModule pREL_REAL_Name +pREL_FLOAT = mkPrelModule pREL_FLOAT_Name \end{code} %************************************************************************ diff --git a/ghc/compiler/prelude/ThinAir.lhs b/ghc/compiler/prelude/ThinAir.lhs index af616fb..147dde2 100644 --- a/ghc/compiler/prelude/ThinAir.lhs +++ b/ghc/compiler/prelude/ThinAir.lhs @@ -7,7 +7,7 @@ module ThinAir ( thinAirIdNames, -- Names of non-wired-in Ids that may be used out of setThinAirIds, -- thin air in any compilation. If they are not wired in - thinAirModules, -- we must be sure to import them from some Prelude + -- we must be sure to import them from some Prelude -- interface file even if they are not overtly -- mentioned. Subset of builtinNames. -- Here are the thin-air Ids themselves @@ -55,7 +55,7 @@ thinAirIdNames = map mkKnownKeyGlobal [ -- Needed for converting literals to Integers (used in tidyCoreExpr) - (varQual pREL_BASE_Name SLIT("addr2Integer"), addr2IntegerIdKey) + (varQual pREL_NUM_Name SLIT("addr2Integer"), addr2IntegerIdKey) -- String literals , (varQual pREL_PACK_Name SLIT("packCString#"), packCStringIdKey) @@ -70,8 +70,6 @@ thinAirIdNames ] varQual = mkPreludeQual varName - -thinAirModules = [pREL_PACK_Name,pREL_BASE_Name] -- See notes with RnIfaces.findAndReadIface \end{code} diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 894fd7d..8f6e76b 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -317,8 +317,8 @@ isAddrTy ty \begin{code} floatTy = mkTyConTy floatTyCon -floatTyCon = pcNonRecDataTyCon floatTyConKey pREL_BASE SLIT("Float") [] [] [floatDataCon] -floatDataCon = pcDataCon floatDataConKey pREL_BASE SLIT("F#") [] [] [floatPrimTy] floatTyCon +floatTyCon = pcNonRecDataTyCon floatTyConKey pREL_FLOAT SLIT("Float") [] [] [floatDataCon] +floatDataCon = pcDataCon floatDataConKey pREL_FLOAT SLIT("F#") [] [] [floatPrimTy] floatTyCon isFloatTy :: Type -> Bool isFloatTy ty @@ -337,8 +337,8 @@ isDoubleTy ty Just (tycon, [], _) -> getUnique tycon == doubleTyConKey _ -> False -doubleTyCon = pcNonRecDataTyCon doubleTyConKey pREL_BASE SLIT("Double") [] [] [doubleDataCon] -doubleDataCon = pcDataCon doubleDataConKey pREL_BASE SLIT("D#") [] [] [doublePrimTy] doubleTyCon +doubleTyCon = pcNonRecDataTyCon doubleTyConKey pREL_FLOAT SLIT("Double") [] [] [doubleDataCon] +doubleDataCon = pcDataCon doubleDataConKey pREL_FLOAT SLIT("D#") [] [] [doublePrimTy] doubleTyCon \end{code} \begin{code} @@ -372,12 +372,12 @@ foreignObjTyCon integerTy :: Type integerTy = mkTyConTy integerTyCon -integerTyCon = pcNonRecDataTyCon integerTyConKey pREL_BASE SLIT("Integer") +integerTyCon = pcNonRecDataTyCon integerTyConKey pREL_NUM SLIT("Integer") [] [] [smallIntegerDataCon, largeIntegerDataCon] -smallIntegerDataCon = pcDataCon smallIntegerDataConKey pREL_BASE SLIT("S#") +smallIntegerDataCon = pcDataCon smallIntegerDataConKey pREL_NUM SLIT("S#") [] [] [intPrimTy] integerTyCon -largeIntegerDataCon = pcDataCon largeIntegerDataConKey pREL_BASE SLIT("J#") +largeIntegerDataCon = pcDataCon largeIntegerDataConKey pREL_NUM SLIT("J#") [] [] [intPrimTy, byteArrayPrimTy] integerTyCon diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index e1381ba..f95b222 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -25,14 +25,14 @@ import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, getImportedRules, loadHomeInterface, getSlurped, removeContext ) import RnEnv ( availName, availNames, availsToNameSet, - warnUnusedTopNames, mapFvRn, lookupImplicitOccRn, + warnUnusedImports, warnUnusedLocalBinds, mapFvRn, lookupImplicitOccRn, FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs ) import Module ( Module, ModuleName, pprModule, mkSearchPath, mkThisModule ) import Name ( Name, isLocallyDefined, NamedThing(..), ImportReason(..), Provenance(..), - pprOccName, nameOccName, - getNameProvenance, + pprOccName, nameOccName, nameUnique, + getNameProvenance, isUserImportedExplicitlyName, maybeWiredInTyConName, maybeWiredInIdName, isWiredInName ) import Id ( idType ) @@ -42,7 +42,7 @@ import RdrName ( RdrName ) import NameSet import PrelMods ( mAIN_Name, pREL_MAIN_Name ) import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon, boolTyCon ) -import PrelInfo ( ioTyCon_NAME, numClass_RDR, thinAirIdNames, derivingOccurrences ) +import PrelInfo ( ioTyCon_NAME, thinAirIdNames, fractionalClassKeys, derivingOccurrences ) import Type ( namesOfType, funTyCon ) import ErrUtils ( printErrorsAndWarnings, dumpIfSet, ghcExit ) import BasicTypes ( NewOrData(..) ) @@ -52,6 +52,7 @@ import UniqSupply ( UniqSupply ) import UniqFM ( lookupUFM ) import Util ( equivClasses ) import Maybes ( maybeToBool ) +import SrcLoc ( mkBuiltinSrcLoc ) import Outputable \end{code} @@ -118,7 +119,7 @@ rename this_mod@(HsModule mod_name vers _ imports local_decls loc) in slurpImpDecls real_source_fvs `thenRn` \ rn_imp_decls -> let - rn_all_decls = rn_imp_decls ++ rn_local_decls + rn_all_decls = rn_local_decls ++ rn_imp_decls in -- EXIT IF ERRORS FOUND @@ -164,21 +165,20 @@ mentioned explicitly, but which might be needed by the type checker. \begin{code} implicitFVs mod_name decls = mapRn lookupImplicitOccRn implicit_occs `thenRn` \ implicit_names -> - returnRn (implicit_main `plusFV` - mkNameSet default_tys `plusFV` - mkNameSet thinAirIdNames `plusFV` + returnRn (implicit_main `plusFV` + mkNameSet (map getName default_tycons) `plusFV` + mkNameSet thinAirIdNames `plusFV` mkNameSet implicit_names) - where - -- Add occurrences for Int, Double, and (), because they + -- Add occurrences for Int, and (), because they -- are the types to which ambigious type variables may be defaulted by -- the type checker; so they won't always appear explicitly. -- [The () one is a GHC extension for defaulting CCall results.] -- ALSO: funTyCon, since it occurs implicitly everywhere! -- (we don't want to be bothered with making funTyCon a -- free var at every function application!) - default_tys = [getName intTyCon, getName doubleTyCon, - getName unitTyCon, getName funTyCon, getName boolTyCon] + -- Double is dealt with separately in getGates + default_tycons = [unitTyCon, funTyCon, boolTyCon, intTyCon] -- Add occurrences for IO or PrimIO implicit_main | mod_name == mAIN_Name @@ -190,7 +190,6 @@ implicitFVs mod_name decls -- generate code implicit_occs = foldr ((++) . get) [] decls - get (DefD _) = [numClass_RDR] get (TyClD (TyData _ _ _ _ _ (Just deriv_classes) _ _)) = concat (map get_deriv deriv_classes) get other = [] @@ -229,6 +228,17 @@ isOrphanDecl other = False \end{code} +\begin{code} +dupDefaultDeclErrRn (DefaultDecl _ locn1 : dup_things) + = pushSrcLocRn locn1 $ + addErrRn msg + where + msg = hang (ptext SLIT("Multiple default declarations")) + 4 (vcat (map pp dup_things)) + pp (DefaultDecl _ locn) = ptext SLIT("here was another default declaration") <+> ppr locn +\end{code} + + %********************************************************* %* * \subsection{Slurping declarations} @@ -285,7 +295,7 @@ slurpSourceRefs source_binders source_fvs rnInstDecls decls1 fvs1 gates1 inst_decls `thenRn` \ (decls2, fvs2, gates2) -> go_outer decls2 fvs2 (all_gates `plusFV` gates2) (nameSetToList (gates2 `minusNameSet` all_gates)) - -- Knock out the all_gates because even ifwe don't slurp any new + -- Knock out the all_gates because even if we don't slurp any new -- decls we can get some apparently-new gates from wired-in names go_inner decls fvs gates [] @@ -408,14 +418,25 @@ getGates source_fvs (SigD (IfaceSig _ ty _ _)) = extractHsTyNames ty getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ _ _)) - = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs) + = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs) (map getTyVarName tvs) - `addOneToNameSet` cls + `addOneToNameSet` cls) + `plusFV` maybe_double where get (ClassOpSig n _ _ ty _) | n `elemNameSet` source_fvs = extractHsTyNames ty | otherwise = emptyFVs + -- If we load any numeric class that doesn't have + -- Int as an instance, add Double to the gates. + -- This takes account of the fact that Double might be needed for + -- defaulting, but we don't want to load Double (and all its baggage) + -- if the more exotic classes aren't used at all. + maybe_double | nameUnique cls `elem` fractionalClassKeys + = unitFV (getName doubleTyCon) + | otherwise + = emptyFVs + getGates source_fvs (TyClD (TySynonym tycon tvs ty _)) = delListFromNameSet (extractHsTyNames ty) (map getTyVarName tvs) @@ -510,20 +531,11 @@ reportUnusedNames gbl_env avail_env (ExportEnv export_avails _ _) mentioned_name nameSetToList (defined_names `minusNameSet` really_used_names) -- Filter out the ones only defined implicitly - bad_guys = filter reportableUnusedName defined_but_not_used + bad_locals = [n | n <- defined_but_not_used, isLocallyDefined n] + bad_imps = [n | n <- defined_but_not_used, isUserImportedExplicitlyName n] in - warnUnusedTopNames bad_guys - -reportableUnusedName :: Name -> Bool -reportableUnusedName name - = explicitlyImported (getNameProvenance name) - where - explicitlyImported (LocalDef _ _) = True - -- Report unused defns of local vars - explicitlyImported (NonLocalDef (UserImport _ _ expl) _) = expl - -- Report unused explicit imports - explicitlyImported other = False - -- Don't report others + warnUnusedLocalBinds bad_locals `thenRn_` + warnUnusedImports bad_imps rnDump :: [RenamedHsDecl] -- Renamed imported decls -> [RenamedHsDecl] -- Renamed local decls diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index a4fad13..6231217 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -631,7 +631,10 @@ filterAvail (IEVar v) avail@(AvailTC n ns) = Just (AvailTC n (filter wanted -- import A( op ) -- where op is a class operation -filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail +filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail + -- We don't complain even if the IE says T(..), but + -- no constrs/class ops of T are available + -- Instead that's caught with a warning by the caller filterAvail ie avail = Nothing @@ -694,18 +697,19 @@ mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> %************************************************************************ + \begin{code} -warnUnusedLocalBinds, warnUnusedTopNames, warnUnusedMatches :: [Name] -> RnM d () +warnUnusedLocalBinds, warnUnusedImports, warnUnusedMatches :: [Name] -> RnM d () -warnUnusedTopNames names - | not opt_WarnUnusedBinds && not opt_WarnUnusedImports - = returnRn () -- Don't force ns unless necessary +warnUnusedImports names + | not opt_WarnUnusedImports + = returnRn () -- Don't force names unless necessary | otherwise - = warnUnusedBinds (\ is_local -> not is_local) names + = warnUnusedBinds (const True) names warnUnusedLocalBinds ns | not opt_WarnUnusedBinds = returnRn () - | otherwise = warnUnusedBinds (\ is_local -> is_local) ns + | otherwise = warnUnusedBinds (const True) ns warnUnusedMatches names | opt_WarnUnusedMatches = warnUnusedGroup (const True) names @@ -731,6 +735,12 @@ warnUnusedBinds warn_when_local names ------------------------- +-- NOTE: the function passed to warnUnusedGroup is +-- now always (const True) so we should be able to +-- simplify the code slightly. I'm leaving it there +-- for now just in case I havn't realised why it was there. +-- Looks highly bogus to me. SLPJ Dec 99 + warnUnusedGroup :: (Bool -> Bool) -> [Name] -> RnM d () warnUnusedGroup emit_warning names | null filtered_names = returnRn () diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index ceb91aa..a46eb5b 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -58,7 +58,7 @@ import NameSet import Var ( Id ) import SrcLoc ( mkSrcLoc, SrcLoc ) import PrelMods ( pREL_GHC ) -import PrelInfo ( cCallishTyKeys, thinAirModules ) +import PrelInfo ( cCallishTyKeys ) import Bag import Maybes ( MaybeErr(..), maybeToBool, orElse ) import ListSetOps ( unionLists ) @@ -973,12 +973,18 @@ readIface the_mod file_path context = [], glasgow_exts = 1#, loc = mkSrcLoc (mkFastString file_path) 1 } of - PFailed err -> failWithRn Nothing err POk _ (PIface mod_nm iface) -> warnCheckRn (mod_nm == moduleName the_mod) (hiModuleNameMismatchWarn the_mod mod_nm) `thenRn_` returnRn (Just (the_mod, iface)) + PFailed err -> failWithRn Nothing err + other -> failWithRn Nothing (ptext SLIT("Unrecognisable interface file")) + -- This last case can happen if the interface file is (say) empty + -- in which case the parser thinks it looks like an IdInfo or + -- something like that. Just an artefact of the fact that the + -- parser is used for several purposes at once. + Left err | isDoesNotExistError err -> returnRn Nothing | otherwise -> failWithRn Nothing (cannaeReadFile file_path err) diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index d98dc2a..176eca3 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -413,10 +413,9 @@ filterImports mod (Just (want_hiding, import_items)) avails = addErrRn (badImportItemErr mod item) `thenRn_` returnRn Nothing - | dodgy_import = addWarnRn (dodgyImportWarn mod item) `thenRn_` - returnRn (Just (filtered_avail, explicits)) - - | otherwise = returnRn (Just (filtered_avail, explicits)) + | otherwise + = warnCheckRn (okItem item avail) (dodgyImportWarn mod item) `thenRn_` + returnRn (Just (filtered_avail, explicits)) where wanted_occ = rdrNameOcc (ieName item) @@ -432,13 +431,12 @@ filterImports mod (Just (want_hiding, import_items)) avails IEThingAll _ -> True other -> False - dodgy_import = case (item, avail) of - (IEThingAll _, AvailTC _ [n]) -> True - -- This occurs when you import T(..), but - -- only export T abstractly. The single [n] - -- in the AvailTC is the type or class itself - - other -> False + +okItem (IEThingAll _) (AvailTC _ [n]) = False + -- This occurs when you import T(..), but + -- only export T abstractly. The single [n] + -- in the AvailTC is the type or class itself +okItem _ _ = True \end{code} @@ -608,7 +606,10 @@ exportsFromAvail this_mod (Just export_items) = failWithRn acc (exportItemErr ie) | otherwise -- Phew! It's OK! Now to check the occurrence stuff! - = check_occs ie occs export_avail `thenRn` \ occs' -> + + + = warnCheckRn (okItem ie avail) (dodgyExportWarn ie) `thenRn_` + check_occs ie occs export_avail `thenRn` \ occs' -> returnRn (mods, occs', add_avail avails export_avail) where @@ -659,17 +660,20 @@ badImportItemErr mod ie = sep [ptext SLIT("Module"), quotes (pprModuleName mod), ptext SLIT("does not export"), quotes (ppr ie)] -dodgyImportWarn mod (IEThingAll tc) - = sep [ptext SLIT("Module") <+> quotes (pprModuleName mod) - <+> ptext SLIT("exports") <+> quotes (ppr tc), - ptext SLIT("with no constructors/class operations;"), - ptext SLIT("yet it is imported with a (..)")] +dodgyImportWarn mod item = dodgyMsg (ptext SLIT("import")) item +dodgyExportWarn item = dodgyMsg (ptext SLIT("export")) item +dodgyMsg kind item@(IEThingAll tc) + = sep [ ptext SLIT("The") <+> kind <+> ptext SLIT("item") <+> quotes (ppr item), + ptext SLIT("suggests that") <+> quotes (ppr tc) <+> ptext SLIT("has constructor or class methods"), + ptext SLIT("but it has none; it is a type synonym or abstract type or class") ] + modExportErr mod = hsep [ ptext SLIT("Unknown module in export list: module"), quotes (pprModuleName mod)] exportItemErr export_item - = sep [ ptext SLIT("Bad export item"), quotes (ppr export_item)] + = sep [ ptext SLIT("The export item") <+> quotes (ppr export_item), + ptext SLIT("attempts to export constructors or class methods that are not visible here") ] exportClashErr occ_name ie1 ie2 = hsep [ptext SLIT("The export items"), quotes (ppr ie1) @@ -703,5 +707,4 @@ dupFixityDecl rdr_name loc1 loc2 = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name), ptext SLIT("at ") <+> ppr loc1, ptext SLIT("and") <+> ppr loc2] - \end{code} diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs index 6fe697b..a3c292b 100644 --- a/ghc/compiler/typecheck/TcDefaults.lhs +++ b/ghc/compiler/typecheck/TcDefaults.lhs @@ -12,7 +12,7 @@ import HsSyn ( HsDecl(..), DefaultDecl(..) ) import RnHsSyn ( RenamedHsDecl ) import TcMonad -import TcEnv ( tcLookupClassByKey ) +import TcEnv ( tcLookupClassByKey_maybe ) import TcMonoType ( tcHsType ) import TcSimplify ( tcSimplifyCheckThetas ) @@ -25,7 +25,7 @@ import Util \end{code} \begin{code} -default_default = [integerTy, doubleTy ] +default_default = [integerTy, doubleTy] tcDefaults :: [RenamedHsDecl] -> TcM s [Type] -- defaulting types to heave @@ -35,24 +35,33 @@ tcDefaults decls = tc_defaults [default_decl | DefD default_decl <- decls] tc_defaults [] = returnTc default_default +tc_defaults [DefaultDecl [] locn] + = returnTc [] -- no defaults + tc_defaults [DefaultDecl mono_tys locn] - = tcAddSrcLoc locn $ + = tcLookupClassByKey_maybe numClassKey `thenNF_Tc` \ maybe_num -> + case maybe_num of { + Nothing -> -- Num has not been sucked in, so the defaults will + -- never be used; so simply discard the default decl. + -- This slightly benefits modules that don't use any + -- numeric stuff at all, by avoid the necessity of + -- always sucking in Num + returnTc [] ; + + Just num -> -- The common case + + tcAddSrcLoc locn $ mapTc tcHsType mono_tys `thenTc` \ tau_tys -> - case tau_tys of - [] -> returnTc [] -- no defaults - - _ -> -- Check that all the types are instances of Num -- We only care about whether it worked or not - - tcAddErrCtxt defaultDeclCtxt $ - tcLookupClassByKey numClassKey `thenNF_Tc` \ num -> - tcSimplifyCheckThetas + tcAddErrCtxt defaultDeclCtxt $ + tcSimplifyCheckThetas [{- Nothing given -}] [ (num, [ty]) | ty <- tau_tys ] `thenTc_` - returnTc tau_tys + returnTc tau_tys + } tc_defaults decls@(DefaultDecl _ loc : _) = tcAddSrcLoc loc $ @@ -69,3 +78,4 @@ dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) where pp (DefaultDecl _ locn) = ptext SLIT("here was another default declaration") <+> ppr locn \end{code} + diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 49da0db..6b13551 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -13,7 +13,7 @@ module TcEnv( tcLookupTy, tcLookupTyCon, tcLookupTyConByKey, - tcLookupClass, tcLookupClassByKey, + tcLookupClass, tcLookupClassByKey, tcLookupClassByKey_maybe, tcExtendGlobalValEnv, tcExtendLocalValEnv, tcGetValueEnv, tcSetValueEnv, @@ -332,6 +332,13 @@ tcLookupClassByKey key Just (_, _, AClass cl) -> returnNF_Tc cl other -> pprPanic "tcLookupClassByKey:" (pprUnique10 key) +tcLookupClassByKey_maybe :: Unique -> NF_TcM s (Maybe Class) +tcLookupClassByKey_maybe key + = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> + case lookupUFM_Directly te key of + Just (_, _, AClass cl) -> returnNF_Tc (Just cl) + other -> returnNF_Tc Nothing + tcLookupTyConByKey :: Unique -> NF_TcM s TyCon tcLookupTyConByKey key = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 5bd3471..fb74078 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -585,7 +585,7 @@ creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) || \begin{code} instConstraintErr clas tys - = hang (ptext SLIT("Illegal constaint") <+> + = hang (ptext SLIT("Illegal constraint") <+> quotes (pprConstraint clas tys) <+> ptext SLIT("in instance context")) 4 (ptext SLIT("(Instance contexts must constrain only type variables)")) diff --git a/ghc/docs/users_guide/debugging.vsgml b/ghc/docs/users_guide/debugging.vsgml index 2d99076..f3fed15 100644 --- a/ghc/docs/users_guide/debugging.vsgml +++ b/ghc/docs/users_guide/debugging.vsgml @@ -104,7 +104,7 @@ output) by using @-ddump-all@, or most of them with @-ddump-most@. Some of the most useful ones are: -@-ddump-parsed@: oarser output +@-ddump-parsed@: parser output @-ddump-rn@: renamer output @-ddump-tc@: typechecker output @-ddump-deriv@: derived instances @@ -122,6 +122,10 @@ Some of the most useful ones are: @-ddump-flatC@: flattened Abstract~C @-ddump-realC@: same as what goes to the C compiler @-ddump-asm@: assembly language from the native-code generator +@-ddump-most@: most of the above, plus @-dshow-passes@, @-dsource-stats@, @-ddump-simpl-stats@, +@-ddump-all@: all the above, plus @-ddump-inlinings@, +@-ddump-simpl-iterations@, @-ddump-rn-trace@, +@-ddump-verbose-simpl@, @-ddump-verbose-stg@. -ddump-all option% @@ -331,43 +335,3 @@ Main.skip2{-r1L6-} = trademark of Peyton Jones Enterprises, plc.) %---------------------------------------------------------------------- -Command line options in source files -