Commit e921b2e3 authored by simonpj's avatar simonpj
Browse files

[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.
parent f7989a6d
......@@ -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
......
......@@ -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 &&
......
......@@ -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
......
......@@ -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}
%************************************************************************
......
......@@ -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}
......
......@@ -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
......
......@@ -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
......
......@@ -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 ()
......
......@@ -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)
......
......@@ -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}
......@@ -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}
......@@ -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) ->
......
......@@ -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)"))
......
......@@ -104,7 +104,7 @@ output) by using @-ddump-all@, or most of them with @-ddump-most@.
Some of the most useful ones are:
<descrip>
<tag>@-ddump-parsed@:</tag> oarser output
<tag>@-ddump-parsed@:</tag> parser output
<tag>@-ddump-rn@:</tag> renamer output
<tag>@-ddump-tc@:</tag> typechecker output
<tag>@-ddump-deriv@:</tag> derived instances
......@@ -122,6 +122,10 @@ Some of the most useful ones are:
<tag>@-ddump-flatC@:</tag> <em>flattened</em> Abstract~C
<tag>@-ddump-realC@:</tag> same as what goes to the C compiler
<tag>@-ddump-asm@:</tag> assembly language from the native-code generator
<tag>@-ddump-most@:</tag> most of the above, plus @-dshow-passes@, @-dsource-stats@, @-ddump-simpl-stats@,
<tag>@-ddump-all@:</tag> all the above, plus @-ddump-inlinings@,
@-ddump-simpl-iterations@, @-ddump-rn-trace@,
@-ddump-verbose-simpl@, @-ddump-verbose-stg@.
</descrip>
<nidx>-ddump-all option</nidx>%
......@@ -331,43 +335,3 @@ Main.skip2{-r1L6-} =
trademark of Peyton Jones Enterprises, plc.)
%----------------------------------------------------------------------
<sect2>Command line options in source files
<label id="source-file-options">
<p>
<nidx>sour