[project @ 2000-10-23 16:39:11 by simonpj]
[ghc-hetmet.git] / ghc / compiler / rename / Rename.lhs
1 %
2 % (c) The GRASP Project, Glasgow University, 1992-1998
3 %
4 \section[Rename]{Renaming and dependency analysis passes}
5
6 \begin{code}
7 module Rename ( renameModule ) where
8
9 #include "HsVersions.h"
10
11 import HsSyn
12 import HsPragmas        ( DataPragmas(..) )
13 import RdrHsSyn         ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation )
14 import RnHsSyn          ( RenamedHsModule, RenamedHsDecl, 
15                           extractHsTyNames, extractHsCtxtTyNames
16                         )
17
18 import CmdLineOpts      ( DynFlags, DynFlag(..) )
19 import RnMonad
20 import RnNames          ( getGlobalNames )
21 import RnSource         ( rnSourceDecls, rnDecl )
22 import RnIfaces         ( getImportedInstDecls, importDecl, mkImportInfo, 
23                           getInterfaceExports,
24                           getImportedRules, getSlurped, removeContext,
25                           ImportDeclResult(..), findAndReadIface
26                         )
27 import RnEnv            ( availName, availsToNameSet, 
28                           emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, sortAvails,
29                           warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules,
30                           lookupOrigNames, unknownNameErr,
31                           FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs, addOneFV
32                         )
33 import Module           ( Module, ModuleName, WhereFrom(..),
34                           moduleNameUserString, moduleName, mkModuleInThisPackage,
35                           lookupModuleEnv
36                         )
37 import Name             ( Name, isLocallyDefined, NamedThing(..), getSrcLoc,
38                           nameOccName, nameUnique, nameModule,
39                           isUserExportedName, toRdrName,
40                           mkNameEnv, nameEnvElts, extendNameEnv
41                         )
42 import OccName          ( occNameFlavour, isValOcc )
43 import Id               ( idType )
44 import TyCon            ( isSynTyCon, getSynTyConDefn )
45 import NameSet
46 import TysWiredIn       ( unitTyCon, intTyCon, doubleTyCon, boolTyCon )
47 import PrelNames        ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name,
48                           ioTyCon_RDR,
49                           unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR,
50                           eqString_RDR
51                         )
52 import PrelInfo         ( fractionalClassKeys, derivingOccurrences, wiredInThingEnv )
53 import Type             ( namesOfType, funTyCon )
54 import ErrUtils         ( printErrorsAndWarnings, dumpIfSet, ghcExit )
55 import BasicTypes       ( Version, initialVersion )
56 import Bag              ( isEmptyBag, bagToList )
57 import FiniteMap        ( FiniteMap, eltsFM, fmToList, emptyFM, lookupFM, 
58                           addToFM_C, elemFM, addToFM
59                         )
60 import UniqSupply       ( UniqSupply )
61 import UniqFM           ( lookupUFM )
62 import SrcLoc           ( noSrcLoc )
63 import Maybes           ( maybeToBool, expectJust )
64 import Outputable
65 import IO               ( openFile, IOMode(..) )
66 import HscTypes         ( Finder, PersistentCompilerState, HomeIfaceTable, HomeSymbolTable, 
67                           ModIface(..), TyThing(..),
68                           GlobalRdrEnv, AvailEnv, Avails, GenAvailInfo(..), AvailInfo, 
69                           Provenance(..), pprNameProvenance, ImportReason(..) )
70 import List             ( partition, nub )
71 \end{code}
72
73
74
75 \begin{code}
76 renameModule :: DynFlags -> Finder 
77              -> HomeIfaceTable -> HomeSymbolTable
78              -> PersistentCompilerState 
79              -> Module -> RdrNameHsModule 
80              -> IO (PersistentCompilerState, Maybe ModIface)
81                         -- The mi_decls in the ModIface include
82                         -- ones imported from packages too
83
84 renameModule dflags finder hit hst old_pcs this_module 
85              this_mod@(HsModule _ _ _ _ _ _ loc)
86   =     -- Initialise the renamer monad
87     do {
88         ((maybe_rn_stuff, dump_action), (rn_warns_bag, rn_errs_bag), new_pcs) 
89            <- initRn dflags finder hit hst old_pcs this_module loc (rename this_module this_mod) ;
90
91         -- Check for warnings
92         printErrorsAndWarnings (rn_warns_bag, rn_errs_bag) ;
93
94         -- Dump any debugging output
95         dump_action ;
96
97         -- Return results
98         if not (isEmptyBag rn_errs_bag) then
99             return (old_pcs, Nothing)
100         else
101             return (new_pcs, maybe_rn_stuff)
102     }
103 \end{code}
104
105 \begin{code}
106 rename :: Module -> RdrNameHsModule -> RnMG (Maybe ModIface, IO ())
107 rename this_module this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec loc)
108   =     -- FIND THE GLOBAL NAME ENVIRONMENT
109     getGlobalNames this_mod                     `thenRn` \ maybe_stuff ->
110
111         -- CHECK FOR EARLY EXIT
112     case maybe_stuff of {
113         Nothing ->      -- Everything is up to date; no need to recompile further
114                 rnDump [] []            `thenRn` \ dump_action ->
115                 returnRn (Nothing, dump_action) ;
116
117         Just (gbl_env, local_gbl_env, export_avails, global_avail_env) ->
118
119         -- DEAL WITH DEPRECATIONS
120     rnDeprecs local_gbl_env mod_deprec local_decls      `thenRn` \ my_deprecs ->
121
122         -- DEAL WITH LOCAL FIXITIES
123     fixitiesFromLocalDecls local_gbl_env local_decls    `thenRn` \ local_fixity_env ->
124
125         -- RENAME THE SOURCE
126     initRnMS gbl_env local_fixity_env SourceMode (
127         rnSourceDecls local_decls
128     )                                   `thenRn` \ (rn_local_decls, source_fvs) ->
129
130         -- SLURP IN ALL THE NEEDED DECLARATIONS
131     implicitFVs mod_name rn_local_decls         `thenRn` \ implicit_fvs -> 
132     let
133                 -- The export_fvs make the exported names look just as if they
134                 -- occurred in the source program.  For the reasoning, see the
135                 -- comments with RnIfaces.getImportVersions.
136                 -- We only need the 'parent name' of the avail;
137                 -- that's enough to suck in the declaration.
138         export_fvs      = mkNameSet (map availName export_avails)
139         real_source_fvs = source_fvs `plusFV` export_fvs
140
141         slurp_fvs       = implicit_fvs `plusFV` real_source_fvs
142                 -- It's important to do the "plus" this way round, so that
143                 -- when compiling the prelude, locally-defined (), Bool, etc
144                 -- override the implicit ones. 
145     in
146     slurpImpDecls slurp_fvs             `thenRn` \ rn_imp_decls ->
147
148         -- EXIT IF ERRORS FOUND
149     rnDump rn_imp_decls rn_local_decls          `thenRn` \ dump_action ->
150     checkErrsRn                                 `thenRn` \ no_errs_so_far ->
151     if not no_errs_so_far then
152         -- Found errors already, so exit now
153         returnRn (Nothing, dump_action)
154     else
155
156         -- GENERATE THE VERSION/USAGE INFO
157     mkImportInfo mod_name imports       `thenRn` \ my_usages ->
158
159         -- RETURN THE RENAMED MODULE
160     getNameSupplyRn                     `thenRn` \ name_supply ->
161     getIfacesRn                         `thenRn` \ ifaces ->
162     let
163         direct_import_mods :: [ModuleName]
164         direct_import_mods = nub [m | ImportDecl m _ _ _ _ _ <- imports]
165
166                 -- *don't* just pick the forward edges.  It's entirely possible
167                 -- that a module is only reachable via back edges.
168         user_import ImportByUser = True
169         user_import ImportByUserSource = True
170         user_import _ = False
171
172         -- Export only those fixities that are for names that are
173         --      (a) defined in this module
174         --      (b) exported
175         exported_fixities
176           = mkNameEnv [ (name, fixity)
177                       | FixitySig name fixity loc <- nameEnvElts local_fixity_env,
178                         isUserExportedName name
179                       ]
180
181
182         -- Sort the exports to make them easier to compare for versions
183         my_exports = sortAvails export_avails
184         
185         mod_iface = ModIface {  mi_module   = this_module,
186                                 mi_version  = panic "mi_version: not filled in yet",
187                                 mi_orphan   = any isOrphanDecl rn_local_decls,
188                                 mi_exports  = my_exports,
189                                 mi_usages   = my_usages,
190                                 mi_fixities = exported_fixities,
191                                 mi_deprecs  = my_deprecs,
192                                 mi_decls    = rn_local_decls ++ rn_imp_decls
193                     }
194     in
195
196         -- REPORT UNUSED NAMES, AND DEBUG DUMP 
197     reportUnusedNames mod_name direct_import_mods
198                       gbl_env global_avail_env
199                       export_avails source_fvs
200                       rn_imp_decls                      `thenRn_`
201
202     returnRn (Just mod_iface, dump_action) }
203   where
204     trashed_exports  = {-trace "rnSource:trashed_exports"-} Nothing
205     trashed_imports  = {-trace "rnSource:trashed_imports"-} []
206 \end{code}
207
208 @implicitFVs@ forces the renamer to slurp in some things which aren't
209 mentioned explicitly, but which might be needed by the type checker.
210
211 \begin{code}
212 implicitFVs mod_name decls
213   = lookupOrigNames implicit_occs                       `thenRn` \ implicit_names ->
214     returnRn (mkNameSet (map getName default_tycons)    `plusFV`
215               implicit_names)
216   where
217         -- Add occurrences for Int, and (), because they
218         -- are the types to which ambigious type variables may be defaulted by
219         -- the type checker; so they won't always appear explicitly.
220         -- [The () one is a GHC extension for defaulting CCall results.]
221         -- ALSO: funTyCon, since it occurs implicitly everywhere!
222         --       (we don't want to be bothered with making funTyCon a
223         --        free var at every function application!)
224         -- Double is dealt with separately in getGates
225     default_tycons = [unitTyCon, funTyCon, boolTyCon, intTyCon]
226
227         -- Add occurrences for IO or PrimIO
228     implicit_main |  mod_name == mAIN_Name
229                   || mod_name == pREL_MAIN_Name = [ioTyCon_RDR]
230                   |  otherwise                  = []
231
232         -- Now add extra "occurrences" for things that
233         -- the deriving mechanism, or defaulting, will later need in order to
234         -- generate code
235     implicit_occs = string_occs ++ foldr ((++) . get) implicit_main decls
236
237         -- Virtually every program has error messages in it somewhere
238     string_occs = [unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR,
239                    eqString_RDR]
240
241     get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _ _ _))
242        = concat (map get_deriv deriv_classes)
243     get other = []
244
245     get_deriv cls = case lookupUFM derivingOccurrences cls of
246                         Nothing   -> []
247                         Just occs -> occs
248 \end{code}
249
250 \begin{code}
251 isOrphanDecl (InstD (InstDecl inst_ty _ _ _ _))
252   = not (foldNameSet ((||) . isLocallyDefined) False (extractHsTyNames (removeContext inst_ty)))
253         -- The 'removeContext' is because of
254         --      instance Foo a => Baz T where ...
255         -- The decl is an orphan if Baz and T are both not locally defined,
256         --      even if Foo *is* locally defined
257
258 isOrphanDecl (RuleD (HsRule _ _ _ lhs _ _))
259   = check lhs
260   where
261         -- At the moment we just check for common LHS forms
262         -- Expand as necessary.  Getting it wrong just means
263         -- more orphans than necessary
264     check (HsVar v)       = not (isLocallyDefined v)
265     check (HsApp f a)     = check f && check a
266     check (HsLit _)       = False
267     check (HsOverLit _)   = False
268     check (OpApp l o _ r) = check l && check o && check r
269     check (NegApp e _)    = check e
270     check (HsPar e)       = check e
271     check (SectionL e o)  = check e && check o
272     check (SectionR o e)  = check e && check o
273
274     check other           = True        -- Safe fall through
275
276 isOrphanDecl other = False
277 \end{code}
278
279
280 \begin{code}
281 dupDefaultDeclErrRn (DefaultDecl _ locn1 : dup_things)
282   = pushSrcLocRn locn1  $
283     addErrRn msg
284   where
285     msg = hang (ptext SLIT("Multiple default declarations"))
286                4  (vcat (map pp dup_things))
287     pp (DefaultDecl _ locn) = ptext SLIT("here was another default declaration") <+> ppr locn
288 \end{code}
289
290
291 %*********************************************************
292 %*                                                       *
293 \subsection{Slurping declarations}
294 %*                                                       *
295 %*********************************************************
296
297 \begin{code}
298 -------------------------------------------------------
299 slurpImpDecls source_fvs
300   = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_`
301
302         -- The current slurped-set records all local things
303     getSlurped                                  `thenRn` \ source_binders ->
304     slurpSourceRefs source_binders source_fvs   `thenRn` \ (decls, needed) ->
305
306         -- Then get everything else
307     closeDecls decls needed                     `thenRn` \ decls1 ->
308
309         -- Finally, get any deferred data type decls
310     slurpDeferredDecls decls1                   `thenRn` \ final_decls -> 
311
312     returnRn final_decls
313
314 -------------------------------------------------------
315 slurpSourceRefs :: NameSet                      -- Variables defined in source
316                 -> FreeVars                     -- Variables referenced in source
317                 -> RnMG ([RenamedHsDecl],
318                          FreeVars)              -- Un-satisfied needs
319 -- The declaration (and hence home module) of each gate has
320 -- already been loaded
321
322 slurpSourceRefs source_binders source_fvs
323   = go_outer []                         -- Accumulating decls
324              emptyFVs                   -- Unsatisfied needs
325              emptyFVs                   -- Accumulating gates
326              (nameSetToList source_fvs) -- Things whose defn hasn't been loaded yet
327   where
328         -- The outer loop repeatedly slurps the decls for the current gates
329         -- and the instance decls 
330
331         -- The outer loop is needed because consider
332         --      instance Foo a => Baz (Maybe a) where ...
333         -- It may be that @Baz@ and @Maybe@ are used in the source module,
334         -- but not @Foo@; so we need to chase @Foo@ too.
335         --
336         -- We also need to follow superclass refs.  In particular, 'chasing @Foo@' must
337         -- include actually getting in Foo's class decl
338         --      class Wib a => Foo a where ..
339         -- so that its superclasses are discovered.  The point is that Wib is a gate too.
340         -- We do this for tycons too, so that we look through type synonyms.
341
342     go_outer decls fvs all_gates []     
343         = returnRn (decls, fvs)
344
345     go_outer decls fvs all_gates refs   -- refs are not necessarily slurped yet
346         = traceRn (text "go_outer" <+> ppr refs)                `thenRn_`
347           foldlRn go_inner (decls, fvs, emptyFVs) refs          `thenRn` \ (decls1, fvs1, gates1) ->
348           getImportedInstDecls (all_gates `plusFV` gates1)      `thenRn` \ inst_decls ->
349           rnInstDecls decls1 fvs1 gates1 inst_decls             `thenRn` \ (decls2, fvs2, gates2) ->
350           go_outer decls2 fvs2 (all_gates `plusFV` gates2)
351                                (nameSetToList (gates2 `minusNameSet` all_gates))
352                 -- Knock out the all_gates because even if we don't slurp any new
353                 -- decls we can get some apparently-new gates from wired-in names
354
355     go_inner (decls, fvs, gates) wanted_name
356         = importDecl wanted_name                `thenRn` \ import_result ->
357           case import_result of
358             AlreadySlurped -> returnRn (decls, fvs, gates)
359             WiredIn        -> returnRn (decls, fvs, gates `plusFV` getWiredInGates wanted_name)
360             Deferred       -> returnRn (decls, fvs, gates `addOneFV` wanted_name)       -- It's a type constructor
361                         
362             HereItIs decl -> rnIfaceDecl decl           `thenRn` \ (new_decl, fvs1) ->
363                              returnRn (new_decl : decls, 
364                                        fvs1 `plusFV` fvs,
365                                        gates `plusFV` getGates source_fvs new_decl)
366
367 rnInstDecls decls fvs gates []
368   = returnRn (decls, fvs, gates)
369 rnInstDecls decls fvs gates (d:ds) 
370   = rnIfaceDecl d               `thenRn` \ (new_decl, fvs1) ->
371     rnInstDecls (new_decl:decls) 
372                 (fvs1 `plusFV` fvs)
373                 (gates `plusFV` getInstDeclGates new_decl)
374                 ds
375 \end{code}
376
377
378 \begin{code}
379 -------------------------------------------------------
380 -- closeDecls keeps going until the free-var set is empty
381 closeDecls decls needed
382   | not (isEmptyFVs needed)
383   = slurpDecls decls needed     `thenRn` \ (decls1, needed1) ->
384     closeDecls decls1 needed1
385
386   | otherwise
387   = getImportedRules                    `thenRn` \ rule_decls ->
388     case rule_decls of
389         []    -> returnRn decls -- No new rules, so we are done
390         other -> rnIfaceDecls decls emptyFVs rule_decls         `thenRn` \ (decls1, needed1) ->
391                  closeDecls decls1 needed1
392                  
393
394 -------------------------------------------------------
395 -- Augment decls with any decls needed by needed.
396 -- Return also free vars of the new decls (only)
397 slurpDecls decls needed
398   = go decls emptyFVs (nameSetToList needed) 
399   where
400     go decls fvs []         = returnRn (decls, fvs)
401     go decls fvs (ref:refs) = slurpDecl decls fvs ref   `thenRn` \ (decls1, fvs1) ->
402                               go decls1 fvs1 refs
403
404 -------------------------------------------------------
405 slurpDecl decls fvs wanted_name
406   = importDecl wanted_name              `thenRn` \ import_result ->
407     case import_result of
408         -- Found a declaration... rename it
409         HereItIs decl -> rnIfaceDecl decl               `thenRn` \ (new_decl, fvs1) ->
410                          returnRn (new_decl:decls, fvs1 `plusFV` fvs)
411
412         -- No declaration... (wired in thing, or deferred, or already slurped)
413         other -> returnRn (decls, fvs)
414
415
416 -------------------------------------------------------
417 rnIfaceDecls :: [RenamedHsDecl] -> FreeVars
418              -> [(Module, RdrNameHsDecl)]
419              -> RnM d ([RenamedHsDecl], FreeVars)
420 rnIfaceDecls decls fvs []     = returnRn (decls, fvs)
421 rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d           `thenRn` \ (new_decl, fvs1) ->
422                                 rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds
423
424 rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl)       
425 \end{code}
426
427
428 %*********************************************************
429 %*                                                       *
430 \subsection{Deferred declarations}
431 %*                                                       *
432 %*********************************************************
433
434 The idea of deferred declarations is this.  Suppose we have a function
435         f :: T -> Int
436         data T = T1 A | T2 B
437         data A = A1 X | A2 Y
438         data B = B1 P | B2 Q
439 Then we don't want to load T and all its constructors, and all
440 the types those constructors refer to, and all the types *those*
441 constructors refer to, and so on.  That might mean loading many more
442 interface files than is really necessary.  So we 'defer' loading T.
443
444 But f might be strict, and the calling convention for evaluating
445 values of type T depends on how many constructors T has, so 
446 we do need to load T, but not the full details of the type T.
447 So we load the full decl for T, but only skeleton decls for A and B:
448         f :: T -> Int
449         data T = {- 2 constructors -}
450
451 Whether all this is worth it is moot.
452
453 \begin{code}
454 slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl]
455 slurpDeferredDecls decls = returnRn decls
456
457 {-      OMIT FOR NOW
458 slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl]
459 slurpDeferredDecls decls
460   = getDeferredDecls                                            `thenRn` \ def_decls ->
461     rnIfaceDecls decls emptyFVs (map stripDecl def_decls)       `thenRn` \ (decls1, fvs) ->
462     ASSERT( isEmptyFVs fvs )
463     returnRn decls1
464
465 stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ _ loc name1 name2))
466   = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing NoDataPragmas loc
467                 name1 name2))
468         -- Nuke the context and constructors
469         -- But retain the *number* of constructors!
470         -- Also the tvs will have kinds on them.
471 -}
472 \end{code}
473
474
475 %*********************************************************
476 %*                                                       *
477 \subsection{Extracting the `gates'}
478 %*                                                       *
479 %*********************************************************
480
481 When we import a declaration like
482 \begin{verbatim}
483         data T = T1 Wibble | T2 Wobble
484 \end{verbatim}
485 we don't want to treat @Wibble@ and @Wobble@ as gates
486 {\em unless} @T1@, @T2@ respectively are mentioned by the user program.
487 If only @T@ is mentioned
488 we want only @T@ to be a gate;
489 that way we don't suck in useless instance
490 decls for (say) @Eq Wibble@, when they can't possibly be useful.
491
492 @getGates@ takes a newly imported (and renamed) decl, and the free
493 vars of the source program, and extracts from the decl the gate names.
494
495 \begin{code}
496 getGates source_fvs (SigD (IfaceSig _ ty _ _))
497   = extractHsTyNames ty
498
499 getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ ))
500   = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
501                         (hsTyVarNames tvs)
502      `addOneToNameSet` cls)
503     `plusFV` maybe_double
504   where
505     get (ClassOpSig n _ ty _) 
506         | n `elemNameSet` source_fvs = extractHsTyNames ty
507         | otherwise                  = emptyFVs
508
509         -- If we load any numeric class that doesn't have
510         -- Int as an instance, add Double to the gates. 
511         -- This takes account of the fact that Double might be needed for
512         -- defaulting, but we don't want to load Double (and all its baggage)
513         -- if the more exotic classes aren't used at all.
514     maybe_double | nameUnique cls `elem` fractionalClassKeys 
515                  = unitFV (getName doubleTyCon)
516                  | otherwise
517                  = emptyFVs
518
519 getGates source_fvs (TyClD (TySynonym tycon tvs ty _))
520   = delListFromNameSet (extractHsTyNames ty)
521                        (hsTyVarNames tvs)
522         -- A type synonym type constructor isn't a "gate" for instance decls
523
524 getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _ _ _))
525   = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
526                        (hsTyVarNames tvs)
527     `addOneToNameSet` tycon
528   where
529     get (ConDecl n _ tvs ctxt details _)
530         | n `elemNameSet` source_fvs
531                 -- If the constructor is method, get fvs from all its fields
532         = delListFromNameSet (get_details details `plusFV` 
533                               extractHsCtxtTyNames ctxt)
534                              (hsTyVarNames tvs)
535     get (ConDecl n _ tvs ctxt (RecCon fields) _)
536                 -- Even if the constructor isn't mentioned, the fields
537                 -- might be, as selectors.  They can't mention existentially
538                 -- bound tyvars (typechecker checks for that) so no need for 
539                 -- the deleteListFromNameSet part
540         = foldr (plusFV . get_field) emptyFVs fields
541         
542     get other_con = emptyFVs
543
544     get_details (VanillaCon tys) = plusFVs (map get_bang tys)
545     get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2
546     get_details (RecCon fields)  = plusFVs [get_bang t | (_, t) <- fields]
547
548     get_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t
549                      | otherwise                         = emptyFVs
550
551     get_bang bty = extractHsTyNames (getBangType bty)
552
553 getGates source_fvs other_decl = emptyFVs
554 \end{code}
555
556 @getWiredInGates@ is just like @getGates@, but it sees a wired-in @Name@
557 rather than a declaration.
558
559 \begin{code}
560 getWiredInGates :: Name -> FreeVars
561 getWiredInGates name    -- No classes are wired in
562   = case lookupNameEnv wiredInThingEnv name of
563         Just (AnId the_id) -> getWiredInGates_s (namesOfType (idType the_id))
564
565         Just (ATyCon tc)
566           |  isSynTyCon tc
567           -> getWiredInGates_s (delListFromNameSet (namesOfType ty) (map getName tyvars))
568           where
569              (tyvars,ty)  = getSynTyConDefn tc
570
571         other -> unitFV name
572
573 getWiredInGates_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names)
574 \end{code}
575
576 \begin{code}
577 getInstDeclGates (InstD (InstDecl inst_ty _ _ _ _)) = extractHsTyNames inst_ty
578 getInstDeclGates other                              = emptyFVs
579 \end{code}
580
581
582 %*********************************************************
583 %*                                                       *
584 \subsection{Fixities}
585 %*                                                       *
586 %*********************************************************
587
588 \begin{code}
589 fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG LocalFixityEnv
590 fixitiesFromLocalDecls gbl_env decls
591   = doptRn Opt_WarnUnusedBinds                            `thenRn` \ warn_unused ->
592     foldlRn (getFixities warn_unused) emptyNameEnv decls  `thenRn` \ env -> 
593     traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env)))
594                                                           `thenRn_`
595     returnRn env
596   where
597     getFixities :: Bool -> LocalFixityEnv -> RdrNameHsDecl -> RnMG LocalFixityEnv
598     getFixities warn_uu acc (FixD fix)
599       = fix_decl warn_uu acc fix
600
601     getFixities warn_uu acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ ))
602       = foldlRn (fix_decl warn_uu) acc [sig | FixSig sig <- sigs]
603                 -- Get fixities from class decl sigs too.
604     getFixities warn_uu acc other_decl
605       = returnRn acc
606
607     fix_decl warn_uu acc sig@(FixitySig rdr_name fixity loc)
608         =       -- Check for fixity decl for something not declared
609           case lookupRdrEnv gbl_env rdr_name of {
610             Nothing | warn_uu
611                     -> pushSrcLocRn loc (addWarnRn (unusedFixityDecl rdr_name fixity))
612                        `thenRn_` returnRn acc 
613                     | otherwise -> returnRn acc ;
614         
615             Just ((name,_):_) ->
616
617                 -- Check for duplicate fixity decl
618           case lookupNameEnv acc name of {
619             Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc')
620                                          `thenRn_` returnRn acc ;
621
622             Nothing -> returnRn (extendNameEnv acc name (FixitySig name fixity loc))
623           }}
624 \end{code}
625
626
627 %*********************************************************
628 %*                                                       *
629 \subsection{Deprecations}
630 %*                                                       *
631 %*********************************************************
632
633 For deprecations, all we do is check that the names are in scope.
634 It's only imported deprecations, dealt with in RnIfaces, that we
635 gather them together.
636
637 \begin{code}
638 rnDeprecs :: GlobalRdrEnv -> Maybe DeprecTxt
639            -> [RdrNameHsDecl] -> RnMG [RdrNameDeprecation]
640 rnDeprecs gbl_env mod_deprec decls
641  = mapRn rn_deprec deprecs      `thenRn_` 
642    returnRn (extra_deprec ++ deprecs)
643  where
644    deprecs = [d | DeprecD d <- decls]
645    extra_deprec = case mod_deprec of
646                    Nothing  -> []
647                    Just txt -> [Deprecation (IEModuleContents undefined) txt noSrcLoc]
648
649    rn_deprec (Deprecation ie txt loc)
650      = pushSrcLocRn loc         $
651        mapRn check (ieNames ie)
652
653    check n = case lookupRdrEnv gbl_env n of
654                 Nothing -> addErrRn (unknownNameErr n)
655                 Just _  -> returnRn ()
656 \end{code}
657
658
659 %*********************************************************
660 %*                                                       *
661 \subsection{Unused names}
662 %*                                                       *
663 %*********************************************************
664
665 \begin{code}
666 reportUnusedNames :: ModuleName -> [ModuleName] 
667                   -> GlobalRdrEnv -> AvailEnv
668                   -> Avails -> NameSet -> [RenamedHsDecl] 
669                   -> RnMG ()
670 reportUnusedNames mod_name direct_import_mods 
671                   gbl_env avail_env 
672                   export_avails mentioned_names
673                   imported_decls
674   = warnUnusedModules unused_imp_mods                           `thenRn_`
675     warnUnusedLocalBinds bad_locals                             `thenRn_`
676     warnUnusedImports bad_imp_names                             `thenRn_`
677     printMinimalImports mod_name minimal_imports                `thenRn_`
678     warnDeprecations really_used_names                          `thenRn_`
679     returnRn ()
680
681   where
682     used_names = mentioned_names `unionNameSets` availsToNameSet export_avails
683     
684     -- Now, a use of C implies a use of T,
685     -- if C was brought into scope by T(..) or T(C)
686     really_used_names = used_names `unionNameSets`
687       mkNameSet [ parent_name
688                 | sub_name <- nameSetToList used_names
689     
690                 -- Usually, every used name will appear in avail_env, but there 
691                 -- is one time when it doesn't: tuples and other built in syntax.  When you
692                 -- write (a,b) that gives rise to a *use* of "(,)", so that the
693                 -- instances will get pulled in, but the tycon "(,)" isn't actually
694                 -- in scope.  Also, (-x) gives rise to an implicit use of 'negate'; 
695                 -- similarly,   3.5 gives rise to an implcit use of :%
696                 -- Hence the silent 'False' in all other cases
697               
698                 , Just parent_name <- [case lookupNameEnv avail_env sub_name of
699                                         Just (AvailTC n _) -> Just n
700                                         other              -> Nothing]
701             ]
702     
703     defined_names, defined_and_used, defined_but_not_used :: [(Name,Provenance)]
704     defined_names                            = concat (rdrEnvElts gbl_env)
705     (defined_and_used, defined_but_not_used) = partition used defined_names
706     used (name,_)                            = not (name `elemNameSet` really_used_names)
707     
708     -- Filter out the ones only defined implicitly
709     bad_locals :: [Name]
710     bad_locals     = [n     | (n,LocalDef) <- defined_but_not_used]
711     
712     bad_imp_names :: [(Name,Provenance)]
713     bad_imp_names  = [(n,p) | (n,p@(NonLocalDef (UserImport mod _ True) _)) <- defined_but_not_used,
714                               not (module_unused mod)]
715     
716     -- inst_mods are directly-imported modules that 
717     --  contain instance decl(s) that the renamer decided to suck in
718     -- It's not necessarily redundant to import such modules.
719     --
720     -- NOTE: Consider 
721     --        module This
722     --          import M ()
723     --
724     --   The import M() is not *necessarily* redundant, even if
725     --   we suck in no instance decls from M (e.g. it contains 
726     --   no instance decls, or This contains no code).  It may be 
727     --   that we import M solely to ensure that M's orphan instance 
728     --   decls (or those in its imports) are visible to people who 
729     --   import This.  Sigh. 
730     --   There's really no good way to detect this, so the error message 
731     --   in RnEnv.warnUnusedModules is weakened instead
732     inst_mods :: [ModuleName]
733     inst_mods = [m | InstD (InstDecl _ _ _ (Just dfun) _) <- imported_decls,
734                  let m = moduleName (nameModule dfun),
735                  m `elem` direct_import_mods
736             ]
737     
738     -- To figure out the minimal set of imports, start with the things
739     -- that are in scope (i.e. in gbl_env).  Then just combine them
740     -- into a bunch of avails, so they are properly grouped
741     minimal_imports :: FiniteMap ModuleName AvailEnv
742     minimal_imports0 = emptyFM
743     minimal_imports1 = foldr add_name     minimal_imports0 defined_and_used
744     minimal_imports  = foldr add_inst_mod minimal_imports1 inst_mods
745     
746     add_name (n,NonLocalDef (UserImport m _ _) _) acc = addToFM_C plusAvailEnv acc (moduleName (nameModule n))
747                                                                   (unitAvailEnv (mk_avail n))
748     add_name (n,other_prov)                       acc = acc
749
750     mk_avail n = case lookupNameEnv avail_env n of
751                 Just (AvailTC m _) | n==m      -> AvailTC n [n]
752                                    | otherwise -> AvailTC m [n,m]
753                 Just avail         -> Avail n
754                 Nothing            -> pprPanic "mk_avail" (ppr n)
755     
756     add_inst_mod m acc 
757       | m `elemFM` acc = acc    -- We import something already
758       | otherwise      = addToFM acc m emptyAvailEnv
759         -- Add an empty collection of imports for a module
760         -- from which we have sucked only instance decls
761     
762     -- unused_imp_mods are the directly-imported modules 
763     -- that are not mentioned in minimal_imports
764     unused_imp_mods = [m | m <- direct_import_mods,
765                        not (maybeToBool (lookupFM minimal_imports m)),
766                        m /= pRELUDE_Name]
767     
768     module_unused :: ModuleName -> Bool
769     module_unused mod = mod `elem` unused_imp_mods
770
771
772 warnDeprecations used_names
773   = doptRn Opt_WarnDeprecations                         `thenRn` \ warn_drs ->
774     if not warn_drs then returnRn () else
775
776     getIfacesRn                                         `thenRn` \ ifaces ->
777     getHomeIfaceTableRn                                 `thenRn` \ hit ->
778     let
779         pit     = iPIT ifaces
780         deprecs = [ (n,txt)
781                   | n <- nameSetToList used_names,
782                     Just txt <- [lookup_deprec hit pit n] ]
783     in                    
784     mapRn_ warnDeprec deprecs
785
786   where
787     lookup_deprec hit pit n
788         = case lookupModuleEnv hit mod of
789                 Just iface -> lookup_iface iface n
790                 Nothing    -> case lookupModuleEnv pit mod of
791                                 Just iface -> lookup_iface iface n
792                                 Nothing    -> pprPanic "warnDeprecations:" (ppr n)
793         where
794           mod = nameModule n
795
796     lookup_iface iface n = lookupNameEnv (mi_deprecs iface) n
797
798 -- ToDo: deal with original imports with 'qualified' and 'as M' clauses
799 printMinimalImports mod_name imps
800   = doptRn Opt_D_dump_minimal_imports           `thenRn` \ dump_minimal ->
801     if not dump_minimal then returnRn () else
802
803     mapRn to_ies (fmToList imps)                `thenRn` \ mod_ies ->
804     ioToRnM (do { h <- openFile filename WriteMode ;
805                   printForUser h (vcat (map ppr_mod_ie mod_ies))
806         })                                      `thenRn_`
807     returnRn ()
808   where
809     filename = moduleNameUserString mod_name ++ ".imports"
810     ppr_mod_ie (mod_name, ies) 
811         | mod_name == pRELUDE_Name 
812         = empty
813         | otherwise
814         = ptext SLIT("import") <+> ppr mod_name <> 
815                             parens (fsep (punctuate comma (map ppr ies)))
816
817     to_ies (mod, avail_env) = mapRn to_ie (availEnvElts avail_env)      `thenRn` \ ies ->
818                               returnRn (mod, ies)
819
820     to_ie :: AvailInfo -> RnMG (IE Name)
821     to_ie (Avail n)       = returnRn (IEVar n)
822     to_ie (AvailTC n [m]) = ASSERT( n==m ) 
823                             returnRn (IEThingAbs n)
824     to_ie (AvailTC n ns)  = getInterfaceExports (moduleName (nameModule n)) 
825                                                 ImportBySystem          `thenRn` \ (_, avails) ->
826                             case [ms | AvailTC m ms <- avails, m == n] of
827                               [ms] | all (`elem` ns) ms -> returnRn (IEThingAll n)
828                                    | otherwise          -> returnRn (IEThingWith n (filter (/= n) ns))
829                               other -> pprTrace "to_ie" (ppr n <+> ppr (nameModule n) <+> ppr other) $
830                                        returnRn (IEVar n)
831
832 rnDump  :: [RenamedHsDecl]      -- Renamed imported decls
833         -> [RenamedHsDecl]      -- Renamed local decls
834         -> RnMG (IO ())
835 rnDump imp_decls local_decls
836    = doptRn Opt_D_dump_rn_trace         `thenRn` \ dump_rn_trace ->
837      doptRn Opt_D_dump_rn_stats         `thenRn` \ dump_rn_stats ->
838      doptRn Opt_D_dump_rn               `thenRn` \ dump_rn ->
839      if dump_rn_trace || dump_rn_stats || dump_rn then
840         getRnStats imp_decls            `thenRn` \ stats_msg ->
841         returnRn (printErrs stats_msg >> 
842                   dumpIfSet dump_rn "Renamer:" 
843                             (vcat (map ppr (local_decls ++ imp_decls))))
844      else
845         returnRn (return ())
846 \end{code}
847
848
849 %*********************************************************
850 %*                                                      *
851 \subsection{Statistics}
852 %*                                                      *
853 %*********************************************************
854
855 \begin{code}
856 getRnStats :: [RenamedHsDecl] -> RnMG SDoc
857 getRnStats imported_decls
858   = getIfacesRn                 `thenRn` \ ifaces ->
859     let
860         n_mods = length [() | (_, _, True) <- eltsFM (iImpModInfo ifaces)]
861
862         decls_read     = [decl | (avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces),
863                                 -- Data, newtype, and class decls are in the decls_fm
864                                 -- under multiple names; the tycon/class, and each
865                                 -- constructor/class op too.
866                                 -- The 'True' selects just the 'main' decl
867                                  not (isLocallyDefined (availName avail))
868                              ]
869
870         (cd_rd, dd_rd, nd_rd, sd_rd, vd_rd,     _) = count_decls decls_read
871         (cd_sp, dd_sp, nd_sp, sd_sp, vd_sp, id_sp) = count_decls imported_decls
872
873         unslurped_insts       = iInsts ifaces
874         inst_decls_unslurped  = length (bagToList unslurped_insts)
875         inst_decls_read       = id_sp + inst_decls_unslurped
876
877         stats = vcat 
878                 [int n_mods <+> text "interfaces read",
879                  hsep [ int cd_sp, text "class decls imported, out of", 
880                         int cd_rd, text "read"],
881                  hsep [ int dd_sp, text "data decls imported, out of",  
882                         int dd_rd, text "read"],
883                  hsep [ int nd_sp, text "newtype decls imported, out of",  
884                         int nd_rd, text "read"],
885                  hsep [int sd_sp, text "type synonym decls imported, out of",  
886                         int sd_rd, text "read"],
887                  hsep [int vd_sp, text "value signatures imported, out of",  
888                         int vd_rd, text "read"],
889                  hsep [int id_sp, text "instance decls imported, out of",  
890                         int inst_decls_read, text "read"],
891                  text "cls dcls slurp" <+> fsep (map (ppr . tyClDeclName) 
892                                            [d | TyClD d <- imported_decls, isClassDecl d]),
893                  text "cls dcls read"  <+> fsep (map (ppr . tyClDeclName) 
894                                            [d | TyClD d <- decls_read, isClassDecl d])]
895     in
896     returnRn (hcat [text "Renamer stats: ", stats])
897
898 count_decls decls
899   = (class_decls, 
900      data_decls, 
901      newtype_decls,
902      syn_decls, 
903      val_decls, 
904      inst_decls)
905   where
906     tycl_decls = [d | TyClD d <- decls]
907     (class_decls, data_decls, newtype_decls, syn_decls) = countTyClDecls tycl_decls
908
909     val_decls     = length [() | SigD _   <- decls]
910     inst_decls    = length [() | InstD _  <- decls]
911 \end{code}    
912
913
914 %************************************************************************
915 %*                                                                      *
916 \subsection{Errors and warnings}
917 %*                                                                      *
918 %************************************************************************
919
920 \begin{code}
921 warnDeprec :: (Name, DeprecTxt) -> RnM d ()
922 warnDeprec (name, txt)
923   = pushSrcLocRn (getSrcLoc name)       $
924     addWarnRn                           $
925     sep [ text (occNameFlavour (nameOccName name)) <+> ppr name <+>
926           text "is deprecated:", nest 4 (ppr txt) ]
927
928
929 unusedFixityDecl rdr_name fixity
930   = hsep [ptext SLIT("Unused fixity declaration for"), quotes (ppr rdr_name)]
931
932 dupFixityDecl rdr_name loc1 loc2
933   = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
934           ptext SLIT("at ") <+> ppr loc1,
935           ptext SLIT("and") <+> ppr loc2]
936 \end{code}
937
938
939 %********************************************************
940 %*                                                      *
941 \subsection{Checking usage information}
942 %*                                                      *
943 %********************************************************
944
945 \begin{code}
946 {-
947 checkEarlyExit mod_name
948   = traceRn (text "Considering whether compilation is required...")     `thenRn_`
949
950         -- Read the old interface file, if any, for the module being compiled
951     findAndReadIface doc_str mod_name False {- Not hi-boot -}   `thenRn` \ maybe_iface ->
952
953         -- CHECK WHETHER WE HAVE IT ALREADY
954     case maybe_iface of
955         Left err ->     -- Old interface file not found, so we'd better bail out
956                     traceRn (vcat [ptext SLIT("No old interface file for") <+> ppr mod_name,
957                                    err])                        `thenRn_`
958                     returnRn (outOfDate, Nothing)
959
960         Right iface
961           | panic "checkEarlyExit: ???: not opt_SourceUnchanged"
962           ->    -- Source code changed
963              traceRn (nest 4 (text "source file changed or recompilation check turned off"))    `thenRn_` 
964              returnRn (False, Just iface)
965
966           | otherwise
967           ->    -- Source code unchanged and no errors yet... carry on 
968              checkModUsage (pi_usages iface)    `thenRn` \ up_to_date ->
969              returnRn (up_to_date, Just iface)
970   where
971         -- Only look in current directory, with suffix .hi
972     doc_str = sep [ptext SLIT("need usage info from"), ppr mod_name]
973 \end{code}
974         
975 \begin{code}
976 upToDate  = True
977 outOfDate = False
978
979 checkModUsage :: [ImportVersion OccName] -> RnMG Bool
980 -- Given the usage information extracted from the old
981 -- M.hi file for the module being compiled, figure out
982 -- whether M needs to be recompiled.
983
984 checkModUsage [] = returnRn upToDate            -- Yes!  Everything is up to date!
985
986 checkModUsage ((mod_name, _, _, NothingAtAll) : rest)
987         -- If CurrentModule.hi contains 
988         --      import Foo :: ;
989         -- then that simply records that Foo lies below CurrentModule in the
990         -- hierarchy, but CurrentModule doesn't depend in any way on Foo.
991         -- In this case we don't even want to open Foo's interface.
992   = traceRn (ptext SLIT("Nothing used from:") <+> ppr mod_name) `thenRn_`
993     checkModUsage rest  -- This one's ok, so check the rest
994
995 checkModUsage ((mod_name, _, _, whats_imported)  : rest)
996   = tryLoadInterface doc_str mod_name ImportBySystem    `thenRn` \ (ifaces, maybe_err) ->
997     case maybe_err of {
998         Just err -> out_of_date (sep [ptext SLIT("Can't find version number for module"), 
999                                       ppr mod_name]) ;
1000                 -- Couldn't find or parse a module mentioned in the
1001                 -- old interface file.  Don't complain -- it might just be that
1002                 -- the current module doesn't need that import and it's been deleted
1003
1004         Nothing -> 
1005     let
1006         (_, new_mod_vers, new_fix_vers, new_rule_vers, _, _) 
1007                 = case lookupFM (iImpModInfo ifaces) mod_name of
1008                            Just (_, _, Just stuff) -> stuff
1009
1010         old_mod_vers = case whats_imported of
1011                          Everything v        -> v
1012                          Specifically v _ _ _ -> v
1013                          -- NothingAtAll case dealt with by previous eqn for checkModUsage
1014     in
1015         -- If the module version hasn't changed, just move on
1016     if new_mod_vers == old_mod_vers then
1017         traceRn (sep [ptext SLIT("Module version unchanged:"), ppr mod_name])
1018         `thenRn_` checkModUsage rest
1019     else
1020     traceRn (sep [ptext SLIT("Module version has changed:"), ppr mod_name])
1021     `thenRn_`
1022         -- Module version changed, so check entities inside
1023
1024         -- If the usage info wants to say "I imported everything from this module"
1025         --     it does so by making whats_imported equal to Everything
1026         -- In that case, we must recompile
1027     case whats_imported of {    -- NothingAtAll dealt with earlier
1028         
1029       Everything _ 
1030         -> out_of_date (ptext SLIT("...and I needed the whole module")) ;
1031
1032       Specifically _ old_fix_vers old_rule_vers old_local_vers ->
1033
1034     if old_fix_vers /= new_fix_vers then
1035         out_of_date (ptext SLIT("Fixities changed"))
1036     else if old_rule_vers /= new_rule_vers then
1037         out_of_date (ptext SLIT("Rules changed"))
1038     else        
1039         -- Non-empty usage list, so check item by item
1040     checkEntityUsage mod_name (iDecls ifaces) old_local_vers    `thenRn` \ up_to_date ->
1041     if up_to_date then
1042         traceRn (ptext SLIT("...but the bits I use haven't."))  `thenRn_`
1043         checkModUsage rest      -- This one's ok, so check the rest
1044     else
1045         returnRn outOfDate      -- This one failed, so just bail out now
1046     }}
1047   where
1048     doc_str = sep [ptext SLIT("need version info for"), ppr mod_name]
1049
1050
1051 checkEntityUsage mod decls [] 
1052   = returnRn upToDate   -- Yes!  All up to date!
1053
1054 checkEntityUsage mod decls ((occ_name,old_vers) : rest)
1055   = newGlobalName mod occ_name  `thenRn` \ name ->
1056     case lookupNameEnv decls name of
1057
1058         Nothing       ->        -- We used it before, but it ain't there now
1059                           out_of_date (sep [ptext SLIT("No longer exported:"), ppr name])
1060
1061         Just (new_vers,_,_,_)   -- It's there, but is it up to date?
1062                 | new_vers == old_vers
1063                         -- Up to date, so check the rest
1064                 -> checkEntityUsage mod decls rest
1065
1066                 | otherwise
1067                         -- Out of date, so bale out
1068                 -> out_of_date (sep [ptext SLIT("Out of date:"), ppr name])
1069
1070 out_of_date msg = traceRn msg `thenRn_` returnRn outOfDate
1071 -}
1072 \end{code}
1073
1074