Commit 5e624292 authored by simonpj's avatar simonpj
Browse files

[project @ 2001-02-20 09:40:43 by simonpj]

Decoupling the Prelude [HsExpr, HsLit, HsPat, ParseUtil, Parser.y, PrelNames,
~~~~~~~~~~~~~~~~~~~~~~  Rename, RnEnv, RnExpr, RnHsSyn, Inst, TcEnv, TcMonad,
			TcPat, TcExpr]
The -fno-implicit-prelude flag is meant to arrange that when you write
	3
you get
	fromInt 3
where 'fromInt' is whatever fromInt is in scope at the top level of
the module being compiled.  Similarly for
	* numeric patterns
	* n+k patterns
	* negation

This used to work, but broke when we made the static/dynamic flag distinction.
It's now tidied up a lot.  Here's the plan:

  - PrelNames contains sugarList :: SugarList, which maps built-in names
    to the RdrName that should replace them.  

  - The renamer makes a finite map :: SugarMap, which maps the built-in names
    to the Name of the re-mapped thing

  - The typechecker consults this map via tcLookupSyntaxId when it is doing
    numeric things

At present I've only decoupled numeric syntax, since that is the main demand,
but the scheme is much more robustly extensible than the previous method.

As a result some HsSyn constructors don't need to carry names in them
(notably HsOverLit, NegApp, NPlusKPatIn)
parent d5c7622a
......@@ -38,7 +38,7 @@ import SrcLoc ( SrcLoc )
data HsExpr id pat
= HsVar id -- variable
| HsIPVar id -- implicit parameter
| HsOverLit (HsOverLit id) -- Overloaded literals; eliminated by type checker
| HsOverLit HsOverLit -- Overloaded literals; eliminated by type checker
| HsLit HsLit -- Simple (non-overloaded) literals
| HsLam (Match id pat) -- lambda
......@@ -60,7 +60,6 @@ data HsExpr id pat
-- They are eventually removed by the type checker.
| NegApp (HsExpr id pat) -- negated expr
id -- the negate id (in a HsVar)
| HsPar (HsExpr id pat) -- parenthesised expr
......@@ -250,7 +249,7 @@ ppr_expr (OpApp e1 op fixity e2)
| otherwise = char '`' <> ppr v <> char '`'
-- Put it in backquotes if it's not an operator already
ppr_expr (NegApp e _) = char '-' <+> pprParendExpr e
ppr_expr (NegApp e) = char '-' <+> pprParendExpr e
ppr_expr (HsPar e) = parens (ppr_expr e)
......
......@@ -41,21 +41,19 @@ data HsLit
-- before the typechecker it's just an error value
deriving( Eq )
data HsOverLit name -- An overloaded literal
= HsIntegral Integer name -- Integer-looking literals;
-- The names is "fromInteger"
| HsFractional Rational name -- Frac-looking literals
-- The name is "fromRational"
data HsOverLit -- An overloaded literal
= HsIntegral Integer -- Integer-looking literals;
| HsFractional Rational -- Frac-looking literals
instance Eq (HsOverLit name) where
(HsIntegral i1 _) == (HsIntegral i2 _) = i1 == i2
(HsFractional f1 _) == (HsFractional f2 _) = f1 == f2
instance Eq HsOverLit where
(HsIntegral i1) == (HsIntegral i2) = i1 == i2
(HsFractional f1) == (HsFractional f2) = f1 == f2
instance Ord (HsOverLit name) where
compare (HsIntegral i1 _) (HsIntegral i2 _) = i1 `compare` i2
compare (HsIntegral _ _) (HsFractional _ _) = LT
compare (HsFractional f1 _) (HsFractional f2 _) = f1 `compare` f2
compare (HsFractional f1 _) (HsIntegral _ _) = GT
instance Ord HsOverLit where
compare (HsIntegral i1) (HsIntegral i2) = i1 `compare` i2
compare (HsIntegral _) (HsFractional _) = LT
compare (HsFractional f1) (HsFractional f2) = f1 `compare` f2
compare (HsFractional f1) (HsIntegral _) = GT
\end{code}
\begin{code}
......@@ -73,9 +71,9 @@ instance Outputable HsLit where
ppr (HsIntPrim i) = integer i <> char '#'
ppr (HsLitLit s _) = hcat [text "``", ptext s, text "''"]
instance Outputable (HsOverLit name) where
ppr (HsIntegral i _) = integer i
ppr (HsFractional f _) = rational f
instance Outputable HsOverLit where
ppr (HsIntegral i) = integer i
ppr (HsFractional f) = rational f
\end{code}
......@@ -52,14 +52,10 @@ data InPat name
Fixity -- c.f. OpApp in HsExpr
(InPat name)
| NPatIn (HsOverLit name)
| NPatIn HsOverLit
| NPlusKPatIn name -- n+k pattern
(HsOverLit name) -- It'll always be an HsIntegral, but
-- we need those names to support -fuser-numerics
name -- Name for "-"; this supports -fuser-numerics
-- We don't do the same for >= because that isn't
-- affected by -fuser-numerics
HsOverLit -- It'll always be an HsIntegral
-- We preserve prefix negation and parenthesis for the precedence parser.
......@@ -154,7 +150,7 @@ pprInPat (AsPatIn name pat) = parens (hcat [ppr name, char '@', ppr pat])
pprInPat (ParPatIn pat) = parens (pprInPat pat)
pprInPat (ListPatIn pats) = brackets (interpp'SP pats)
pprInPat (TuplePatIn pats bx) = tupleParens bx (interpp'SP pats)
pprInPat (NPlusKPatIn n k _) = parens (hcat [ppr n, char '+', ppr k])
pprInPat (NPlusKPatIn n k) = parens (hcat [ppr n, char '+', ppr k])
pprInPat (NPatIn l) = ppr l
pprInPat (ConPatIn c pats)
......@@ -320,7 +316,7 @@ collect (LitPatIn _) bndrs = bndrs
collect (SigPatIn pat _) bndrs = collect pat bndrs
collect (LazyPatIn pat) bndrs = collect pat bndrs
collect (AsPatIn a pat) bndrs = a : collect pat bndrs
collect (NPlusKPatIn n _ _) bndrs = n : bndrs
collect (NPlusKPatIn n _) bndrs = n : bndrs
collect (NPatIn _) bndrs = bndrs
collect (ConPatIn c pats) bndrs = foldr collect bndrs pats
collect (ConOpPatIn p1 c f p2) bndrs = collect p1 (collect p2 bndrs)
......@@ -344,7 +340,7 @@ collect_pat (LitPatIn _) acc = acc
collect_pat (LazyPatIn pat) acc = collect_pat pat acc
collect_pat (AsPatIn a pat) acc = collect_pat pat acc
collect_pat (NPatIn _) acc = acc
collect_pat (NPlusKPatIn n _ _) acc = acc
collect_pat (NPlusKPatIn n _) acc = acc
collect_pat (ConPatIn c pats) acc = foldr collect_pat acc pats
collect_pat (ConOpPatIn p1 c f p2) acc = collect_pat p1 (collect_pat p2 acc)
collect_pat (ParPatIn pat) acc = collect_pat pat acc
......
......@@ -200,9 +200,9 @@ checkPat e [] = case e of
in
returnP (SigPatIn e t')
OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral k _))
OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral k))
| plus == plus_RDR
-> returnP (NPlusKPatIn n lit minus_RDR)
-> returnP (NPlusKPatIn n lit)
where
plus_RDR = mkUnqual varName SLIT("+") -- Hack
......
{-
-----------------------------------------------------------------------------
$Id: Parser.y,v 1.52 2001/02/11 09:36:00 qrczak Exp $
$Id: Parser.y,v 1.53 2001/02/20 09:40:43 simonpj Exp $
Haskell grammar.
......@@ -18,7 +18,9 @@ import RdrHsSyn
import Lex
import ParseUtil
import RdrName
import PrelNames
import PrelNames ( mAIN_Name, unitTyCon_RDR, funTyCon_RDR, listTyCon_RDR,
tupleTyCon_RDR, unitCon_RDR, nilCon_RDR, tupleCon_RDR
)
import OccName ( UserFS, varName, ipName, tcName, dataName, tcClsName, tvName )
import SrcLoc ( SrcLoc )
import Module
......@@ -737,8 +739,8 @@ aexp1 :: { RdrNameHsExpr }
: ipvar { HsIPVar $1 }
| var_or_con { $1 }
| literal { HsLit $1 }
| INTEGER { HsOverLit (HsIntegral $1 fromInteger_RDR) }
| RATIONAL { HsOverLit (HsFractional $1 fromRational_RDR) }
| INTEGER { HsOverLit (HsIntegral $1) }
| RATIONAL { HsOverLit (HsFractional $1) }
| '(' exp ')' { HsPar $2 }
| '(' exp ',' texps ')' { ExplicitTuple ($2 : reverse $4) Boxed}
| '(#' texps '#)' { ExplicitTuple (reverse $2) Unboxed }
......
......@@ -22,6 +22,8 @@ module PrelNames (
knownKeyNames,
mkTupNameStr, mkTupConRdrName,
SyntaxMap, vanillaSyntaxMap, SyntaxList, syntaxList,
------------------------------------------------------------
-- Goups of classes and types
needsDataDeclCtxtClassKeys, cCallishClassKeys, noDictClassKeys,
......@@ -109,6 +111,7 @@ knownKeyNames
-- ClassOps
fromIntName,
fromIntegerName,
negateName,
geName,
minusName,
enumFromName,
......@@ -376,6 +379,7 @@ numClassName = clsQual pREL_NUM_Name SLIT("Num") numClassKey
fromIntName = varQual pREL_NUM_Name SLIT("fromInt") fromIntClassOpKey
fromIntegerName = varQual pREL_NUM_Name SLIT("fromInteger") fromIntegerClassOpKey
minusName = varQual pREL_NUM_Name SLIT("-") minusClassOpKey
negateName = varQual pREL_NUM_Name SLIT("negate") negateClassOpKey
plusIntegerName = varQual pREL_NUM_Name SLIT("plusInteger") plusIntegerIdKey
timesIntegerName = varQual pREL_NUM_Name SLIT("timesInteger") timesIntegerIdKey
integerTyConName = tcQual pREL_NUM_Name SLIT("Integer") integerTyConKey
......@@ -814,6 +818,7 @@ enumFromToClassOpKey = mkPreludeMiscIdUnique 107
enumFromThenToClassOpKey = mkPreludeMiscIdUnique 108
eqClassOpKey = mkPreludeMiscIdUnique 109
geClassOpKey = mkPreludeMiscIdUnique 110
negateClassOpKey = mkPreludeMiscIdUnique 111
failMClassOpKey = mkPreludeMiscIdUnique 112
thenMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=)
-- Just a place holder for unbound variables produced by the renamer:
......@@ -871,6 +876,49 @@ cCallishTyKeys =
\end{code}
%************************************************************************
%* *
\subsection{Re-bindable desugaring names}
%* *
%************************************************************************
Haskell 98 says that when you say "3" you get the "fromInt" from the
Standard Prelude, regardless of what is in scope. However, to experiment
with having a language that is less coupled to the standard prelude, we're
trying a non-standard extension that instead gives you whatever "Prelude.fromInt"
happens to be in scope. Then you can
import Prelude ()
import MyPrelude as Prelude
to get the desired effect.
The SyntaxNames record gives all the names you can rebind in this way.
This record of names needs to go through the renamer to map RdrNames to
Names (i.e. look up the names in the in-scope environment), to suck in
their type signatures from interface file(s).
\begin{code}
type SyntaxList = [(Name, RdrName)]
-- Maps a Name, which identifies the standard built-in thing
-- to a RdrName for the re-mapped version of the built-in thing
syntaxList :: SyntaxList
syntaxList =[ (fromIntName, mkUnqual varName SLIT("fromInt"))
, (fromIntegerName, mkUnqual varName SLIT("fromInteger"))
, (fromRationalName, mkUnqual varName SLIT("fromRational"))
, (negateName, mkUnqual varName SLIT("negate"))
, (minusName, mkUnqual varName SLIT("-"))
-- For now that's all. We may add booleans and lists later.
]
type SyntaxMap = Name -> Name
-- Maps a standard built-in name, such as PrelNum.fromInt
-- to its re-mapped version, such as MyPrelude.fromInt
vanillaSyntaxMap name = name
\end{code}
%************************************************************************
%* *
\subsection[Class-std-groups]{Standard groups of Prelude classes}
......
......@@ -23,45 +23,36 @@ import RnExpr ( rnExpr )
import RnNames ( getGlobalNames, exportsFromAvail )
import RnSource ( rnSourceDecls, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl )
import RnIfaces ( slurpImpDecls, mkImportInfo, recordLocalSlurps,
getInterfaceExports, closeDecls,
closeDecls,
RecompileRequired, outOfDate, recompileRequired
)
import RnHiFiles ( readIface, removeContext, loadInterface,
loadExports, loadFixDecls, loadDeprecs,
tryLoadInterface )
import RnEnv ( availsToNameSet, availName, mkIfaceGlobalRdrEnv,
import RnEnv ( availsToNameSet, mkIfaceGlobalRdrEnv,
emptyAvailEnv, unitAvailEnv, availEnvElts,
plusAvailEnv, groupAvails, warnUnusedImports,
warnUnusedLocalBinds, warnUnusedModules,
lookupOrigNames, lookupSrcName,
newGlobalName, unQualInScope
lookupSrcName, addImplicitFVs,
newGlobalName, unQualInScope,, ubiquitousNames
)
import Module ( Module, ModuleName, WhereFrom(..),
moduleNameUserString, moduleName,
moduleEnvElts
)
import Name ( Name, NamedThing(..), getSrcLoc,
import Name ( Name, NamedThing(..),
nameIsLocalOrFrom, nameOccName, nameModule,
)
import Name ( mkNameEnv, nameEnvElts, extendNameEnv )
import RdrName ( foldRdrEnv, isQual )
import OccName ( occNameFlavour )
import NameSet
import TysWiredIn ( unitTyCon, intTyCon, boolTyCon )
import PrelNames ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name,
ioTyConName, printName,
unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name,
eqStringName
)
import PrelInfo ( derivingOccurrences )
import Type ( funTyCon )
import PrelNames ( SyntaxMap, pRELUDE_Name )
import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass,
printErrorsAndWarnings, errorsFound )
import Bag ( bagToList )
import FiniteMap ( FiniteMap, fmToList, emptyFM, lookupFM,
addToFM_C, elemFM, addToFM
)
import UniqFM ( lookupWithDefaultUFM )
import Maybes ( maybeToBool, catMaybes )
import Outputable
import IO ( openFile, IOMode(..) )
......@@ -69,10 +60,10 @@ import HscTypes ( PersistentCompilerState, HomeIfaceTable, HomeSymbolTable,
ModIface(..), WhatsImported(..),
VersionInfo(..), ImportVersion, IsExported,
IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
GlobalRdrEnv, pprGlobalRdrEnv,
GlobalRdrEnv, GlobalRdrElt(..), pprGlobalRdrEnv,
AvailEnv, GenAvailInfo(..), AvailInfo, Avails,
Provenance(..), ImportReason(..), initialVersionInfo,
Deprecations(..), lookupDeprec, lookupIface
Deprecations(..)
)
import CmStaticInfo ( GhciMode(..) )
import List ( partition, nub )
......@@ -92,7 +83,8 @@ renameModule :: DynFlags
-> HomeIfaceTable -> HomeSymbolTable
-> PersistentCompilerState
-> Module -> RdrNameHsModule
-> IO (PersistentCompilerState, Maybe (PrintUnqualified, (IsExported, ModIface, [RenamedHsDecl])))
-> IO (PersistentCompilerState,
Maybe (PrintUnqualified, (IsExported, ModIface, (SyntaxMap, [RenamedHsDecl]))))
-- Nothing => some error occurred in the renamer
renameModule dflags hit hst pcs this_module rdr_module
......@@ -107,7 +99,7 @@ renameExpr :: DynFlags
-> PersistentCompilerState
-> Module -> RdrNameHsExpr
-> IO ( PersistentCompilerState,
Maybe (PrintUnqualified, (RenamedHsExpr, [RenamedHsDecl]))
Maybe (PrintUnqualified, (SyntaxMap, RenamedHsExpr, [RenamedHsDecl]))
)
renameExpr dflags hit hst pcs this_module expr
......@@ -136,16 +128,11 @@ renameExpr dflags hit hst pcs this_module expr
returnRn Nothing
else
let
implicit_fvs = fvs `plusFV` string_names
`plusFV` default_tycon_names
`plusFV` unitFV printName
-- print :: a -> IO () may be needed later
in
slurpImpDecls (fvs `plusFV` implicit_fvs) `thenRn` \ decls ->
addImplicitFVs rdr_env Nothing fvs `thenRn` \ (slurp_fvs, syntax_map) ->
slurpImpDecls slurp_fvs `thenRn` \ decls ->
doDump e decls `thenRn_`
returnRn (Just (print_unqual, (e, decls)))
returnRn (Just (print_unqual, (syntax_map, e, decls)))
}
where
doc = text "context for compiling expression"
......@@ -195,7 +182,8 @@ renameSource dflags hit hst old_pcs this_module thing_inside
\end{code}
\begin{code}
rename :: Module -> RdrNameHsModule -> RnMG (Maybe (PrintUnqualified, (IsExported, ModIface, [RenamedHsDecl])))
rename :: Module -> RdrNameHsModule
-> RnMG (Maybe (PrintUnqualified, (IsExported, ModIface, (SyntaxMap, [RenamedHsDecl]))))
rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec loc)
= pushSrcLocRn loc $
......@@ -239,13 +227,8 @@ rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec
else
-- SLURP IN ALL THE NEEDED DECLARATIONS
implicitFVs mod_name rn_local_decls `thenRn` \ implicit_fvs ->
let
slurp_fvs = implicit_fvs `plusFV` source_fvs
-- It's important to do the "plus" this way round, so that
-- when compiling the prelude, locally-defined (), Bool, etc
-- override the implicit ones.
in
addImplicitFVs gbl_env (Just (mod_name, rn_local_decls))
source_fvs `thenRn` \ (slurp_fvs, sugar_map) ->
traceRn (text "Source FVs:" <+> fsep (map ppr (nameSetToList slurp_fvs))) `thenRn_`
slurpImpDecls slurp_fvs `thenRn` \ rn_imp_decls ->
......@@ -290,47 +273,11 @@ rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec
imports global_avail_env
source_fvs export_avails rn_imp_decls `thenRn_`
returnRn (Just (print_unqualified, (is_exported, mod_iface, final_decls)))
returnRn (Just (print_unqualified, (is_exported, mod_iface, (sugar_map, final_decls))))
where
mod_name = moduleName this_module
\end{code}
@implicitFVs@ forces the renamer to slurp in some things which aren't
mentioned explicitly, but which might be needed by the type checker.
\begin{code}
implicitFVs mod_name decls
= lookupOrigNames deriv_occs `thenRn` \ deriving_names ->
returnRn (default_tycon_names `plusFV`
string_names `plusFV`
deriving_names `plusFV`
implicit_main)
where
-- Add occurrences for IO or PrimIO
implicit_main | mod_name == mAIN_Name
|| mod_name == pREL_MAIN_Name = unitFV ioTyConName
| otherwise = emptyFVs
deriv_occs = [occ | TyClD (TyData {tcdDerivs = Just deriv_classes}) <- decls,
cls <- deriv_classes,
occ <- lookupWithDefaultUFM derivingOccurrences [] cls ]
-- Virtually every program has error messages in it somewhere
string_names = mkFVs [unpackCStringName, unpackCStringFoldrName,
unpackCStringUtf8Name, eqStringName]
-- 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!)
-- Double is dealt with separately in getGates
default_tycon_names = mkFVs (map getName [unitTyCon, funTyCon, boolTyCon, intTyCon])
\end{code}
\begin{code}
isOrphanDecl this_mod (InstD (InstDecl inst_ty _ _ _ _))
= not (foldNameSet ((||) . nameIsLocalOrFrom this_mod) False
......@@ -351,7 +298,7 @@ isOrphanDecl this_mod (RuleD (HsRule _ _ _ lhs _ _))
check (HsLit _) = False
check (HsOverLit _) = False
check (OpApp l o _ r) = check l && check o && check r
check (NegApp e _) = check e
check (NegApp e) = check e
check (HsPar e) = check e
check (SectionL e o) = check e && check o
check (SectionR o e) = check e && check o
......@@ -610,9 +557,9 @@ closeIfaceDecls dflags hit hst pcs
rnDump [] closed_decls `thenRn_`
returnRn closed_decls
where
implicit_fvs = string_names -- Data type decls with record selectors,
-- which may appear in the decls, need unpackCString
-- and friends. It's easier to just grab them right now.
implicit_fvs = ubiquitousNames -- Data type decls with record selectors,
-- which may appear in the decls, need unpackCString
-- and friends. It's easier to just grab them right now.
\end{code}
%*********************************************************
......@@ -634,14 +581,10 @@ reportUnusedNames my_mod_iface unqual imports avail_env
= warnUnusedModules unused_imp_mods `thenRn_`
warnUnusedLocalBinds bad_locals `thenRn_`
warnUnusedImports bad_imp_names `thenRn_`
printMinimalImports this_mod unqual minimal_imports `thenRn_`
warnDeprecations this_mod export_avails my_deprecs
really_used_names
printMinimalImports this_mod unqual minimal_imports
where
this_mod = mi_module my_mod_iface
gbl_env = mi_globals my_mod_iface
my_deprecs = mi_deprecs my_mod_iface
-- The export_fvs make the exported names look just as if they
-- occurred in the source program.
......@@ -669,21 +612,21 @@ reportUnusedNames my_mod_iface unqual imports avail_env
-- Collect the defined names from the in-scope environment
-- Look for the qualified ones only, else get duplicates
defined_names :: [(Name,Provenance)]
defined_names :: [GlobalRdrElt]
defined_names = foldRdrEnv add [] gbl_env
add rdr_name ns acc | isQual rdr_name = ns ++ acc
| otherwise = acc
defined_and_used, defined_but_not_used :: [(Name,Provenance)]
defined_and_used, defined_but_not_used :: [GlobalRdrElt]
(defined_and_used, defined_but_not_used) = partition used defined_names
used (name,_) = name `elemNameSet` really_used_names
used (GRE name _ _) = name `elemNameSet` really_used_names
-- Filter out the ones only defined implicitly
bad_locals :: [Name]
bad_locals = [n | (n,LocalDef) <- defined_but_not_used]
bad_locals = [n | (GRE n LocalDef _) <- defined_but_not_used]
bad_imp_names :: [(Name,Provenance)]
bad_imp_names = [(n,p) | (n,p@(NonLocalDef (UserImport mod _ True))) <- defined_but_not_used,
bad_imp_names = [(n,p) | GRE n p@(NonLocalDef (UserImport mod _ True)) _ <- defined_but_not_used,
not (module_unused mod)]
-- inst_mods are directly-imported modules that
......@@ -719,9 +662,9 @@ reportUnusedNames my_mod_iface unqual imports avail_env
-- We've carefully preserved the provenance so that we can
-- construct minimal imports that import the name by (one of)
-- the same route(s) as the programmer originally did.
add_name (n,NonLocalDef (UserImport m _ _)) acc = addToFM_C plusAvailEnv acc (moduleName m)
(unitAvailEnv (mk_avail n))
add_name (n,other_prov) acc = acc
add_name (GRE n (NonLocalDef (UserImport m _ _)) _) acc = addToFM_C plusAvailEnv acc (moduleName m)
(unitAvailEnv (mk_avail n))
add_name (GRE n other_prov _) acc = acc
mk_avail n = case lookupNameEnv avail_env n of
Just (AvailTC m _) | n==m -> AvailTC n [n]
......@@ -747,46 +690,12 @@ reportUnusedNames my_mod_iface unqual imports avail_env
module_unused :: Module -> Bool
module_unused mod = moduleName mod `elem` unused_imp_mods
warnDeprecations this_mod export_avails my_deprecs used_names
= doptRn Opt_WarnDeprecations `thenRn` \ warn_drs ->
if not warn_drs then returnRn () else
-- The home modules for things in the export list
-- may not have been loaded yet; do it now, so
-- that we can see their deprecations, if any
mapRn_ load_home export_mods `thenRn_`
getIfacesRn `thenRn` \ ifaces ->
getHomeIfaceTableRn `thenRn` \ hit ->
let
pit = iPIT ifaces
deprecs = [ (n,txt)
| n <- nameSetToList used_names,
not (nameIsLocalOrFrom this_mod n),
Just txt <- [lookup_deprec hit pit n] ]
-- nameIsLocalOrFrom: don't complain about locally defined names
-- For a start, we may be exporting a deprecated thing
-- Also we may use a deprecated thing in the defn of another
-- deprecated things. We may even use a deprecated thing in
-- the defn of a non-deprecated thing, when changing a module's
-- interface
in
mapRn_ warnDeprec deprecs
where
export_mods = nub [ moduleName mod
| avail <- export_avails,
let mod = nameModule (availName avail),
mod /= this_mod ]
load_home m = loadInterface (text "Check deprecations for" <+> ppr m) m ImportBySystem
lookup_deprec hit pit n
= case lookupIface hit pit n of
Just iface -> lookupDeprec (mi_deprecs iface) n
Nothing -> pprPanic "warnDeprecations:" (ppr n)
-- ToDo: deal with original imports with 'qualified' and 'as M' clauses
printMinimalImports :: Module -- This module
-> PrintUnqualified
-> FiniteMap ModuleName AvailEnv -- Minimal imports
-> RnMG ()
printMinimalImports this_mod unqual imps
= doptRn Opt_D_dump_minimal_imports `thenRn` \ dump_minimal ->
if not dump_minimal then returnRn () else
......@@ -809,12 +718,15 @@ printMinimalImports this_mod unqual imps
returnRn (mod, ies)
to_ie :: AvailInfo -> RnMG (IE Name)
-- The main trick here is that if we're importing all the constructors
-- we want to say "T(..)", but if we're importing only a subset we want
-- to say "T(A,B,C)". So we have to find out what the module exports.
to_ie (Avail n) = returnRn (IEVar n)
to_ie (AvailTC n [m]) = ASSERT( n==m )
returnRn (IEThingAbs n)
to_ie (AvailTC n ns)
= getInterfaceExports n_mod ImportBySystem `thenRn` \ (_, avails_by_module) ->
case [xs | (m,as) <- avails_by_module,
= loadInterface (text "Compute minimal imports from" <+> ppr n_mod) n_mod ImportBySystem `thenRn` \ iface ->
case [xs | (m,as) <- mi_exports iface,
m == n_mod,
AvailTC x xs <- as,
x == n] of
......@@ -894,14 +806,6 @@ getRnStats imported_decls ifaces
%************************************************************************
\begin{code}
warnDeprec :: (Name, DeprecTxt) -> RnM d ()
warnDeprec (name, txt)
= pushSrcLocRn (getSrcLoc name) $
addWarnRn $
sep [ text (occNameFlavour (nameOccName name)) <+> quotes (ppr name) <+>
text "is deprecated:", nest 4 (ppr txt) ]
dupFixityDecl rdr_name loc1 loc2
= vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
ptext SLIT("at ") <+> ppr loc1,
......
......@@ -12,27 +12,38 @@ import {-# SOURCE #-} RnHiFiles
import HscTypes ( ModIface(..) )
import HsSyn
import RnHsSyn ( RenamedHsDecl )
import RdrHsSyn ( RdrNameIE )
import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
mkRdrUnqual, mkRdrQual, qualifyRdrName, lookupRdrEnv, foldRdrEnv
)
import HsTypes ( hsTyVarName, replaceTyVarName )
import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv,
ImportReason(..), GlobalRdrEnv, AvailEnv,
AvailInfo, Avails, GenAvailInfo(..), NameSupply(..) )
ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), AvailEnv,
AvailInfo, Avails, GenAvailInfo(..), NameSupply(..),
Deprecations(..), lookupDeprec
)
import RnMonad
import Name ( Name,
getSrcLoc,
mkLocalName, mkGlobalName,
mkIPName, nameOccName, nameModule_maybe,
setNameModuleAndLoc
setNameModuleAndLoc, mkNameEnv
)
import Name ( extendNameEnv_C, plusNameEnv_C, nameEnvElts )
import NameSet
import OccName ( OccName, occNameUserString, occNameFlavour )
import Module ( ModuleName, moduleName, mkVanillaModule,
mkSysModuleNameFS, moduleNameFS,
WhereFrom(..) )
mkSysModuleNameFS, moduleNameFS, WhereFrom(..) )
import TysWiredIn ( unitTyCon, intTyCon, boolTyCon )
import Type ( funTyCon )
import PrelNames ( mkUnboundName, syntaxList, SyntaxMap, vanillaSyntaxMap,
derivingOccurrences,
mAIN_Name, pREL_MAIN_Name,
ioTyConName, printName,
unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name,
eqStringName
)
import FiniteMap
import UniqSupply
import SrcLoc ( SrcLoc, noSrcLoc )
......@@ -40,7 +51,8 @@ import Outputable
import ListSetOps ( removeDups, equivClasses )
import Util ( sortLt )
import List ( nub )
import PrelNames ( mkUnboundName )
import UniqFM ( lookupWithDefaultUFM )
import Maybes ( orElse )
import CmdLineOpts
import FastString ( FastString )
\end{code}
......@@ -62,7 +74,6 @@ newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name
newTopBinder mod rdr_name loc
= -- First check the cache
-- traceRn (text "newTopBinder" <+> ppr mod <+> ppr loc) `thenRn_`
-- There should never be a qualified name in a binding position (except in instance decls)
-- The parser doesn't check this because the same parser parses instance decls
......@@ -92,7 +103,7 @@ newTopBinder mod rdr_name loc
new_cache = addToFM cache key new_name
in
setNameSupplyRn (name_supply {nsNames = new_cache}) `thenRn_`
traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_`
-- traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_`
returnRn new_name
-- Miss in the cache!
......@@ -106,7 +117,7 @@ newTopBinder mod rdr_name loc
new_cache = addToFM cache key new_name
in
setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_`
traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_`
-- traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_`
returnRn new_name