Clean up some outdated comments (#8418)
[ghc.git] / compiler / typecheck / TcRnDriver.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5 \section[TcMovectle]{Typechecking a whole module}
6
7 \begin{code}
8 module TcRnDriver (
9 #ifdef GHCI
10         tcRnStmt, tcRnExpr, tcRnType,
11         tcRnImportDecls,
12         tcRnLookupRdrName,
13         getModuleInterface,
14         tcRnDeclsi,
15         isGHCiMonad,
16 #endif
17         tcRnLookupName,
18         tcRnGetInfo,
19         tcRnModule, tcRnModuleTcRnM,
20         tcTopSrcDecls,
21         tcRnExtCore
22     ) where
23
24 #ifdef GHCI
25 import {-# SOURCE #-} TcSplice ( tcSpliceDecls, runQuasi )
26 import RnSplice ( rnSplice )
27 #endif
28
29 import DynFlags
30 import StaticFlags
31 import HsSyn
32 import PrelNames
33 import RdrName
34 import TcHsSyn
35 import TcExpr
36 import TcRnMonad
37 import TcEvidence
38 import PprTyThing( pprTyThing )
39 import Coercion( pprCoAxiom )
40 import FamInst
41 import InstEnv
42 import FamInstEnv
43 import TcAnnotations
44 import TcBinds
45 import HeaderInfo       ( mkPrelImports )
46 import TcDefaults
47 import TcEnv
48 import TcRules
49 import TcForeign
50 import TcInstDcls
51 import TcIface
52 import TcMType
53 import MkIface
54 import TcSimplify
55 import TcTyClsDecls
56 import LoadIface
57 import RnNames
58 import RnEnv
59 import RnSource
60 import PprCore
61 import CoreSyn
62 import ErrUtils
63 import Id
64 import VarEnv
65 import Module
66 import UniqFM
67 import Name
68 import NameEnv
69 import NameSet
70 import Avail
71 import TyCon
72 import SrcLoc
73 import HscTypes
74 import ListSetOps
75 import Outputable
76 import DataCon
77 import Type
78 import Class
79 import CoAxiom
80 import Inst     ( tcGetInstEnvs, tcGetInsts )
81 import Data.List ( sortBy )
82 import Data.IORef ( readIORef )
83 import Data.Ord
84
85 #ifdef GHCI
86 import TcType   ( isUnitTy, isTauTy )
87 import TcHsType
88 import TcMatches
89 import RnTypes
90 import RnExpr
91 import MkId
92 import BasicTypes hiding( SuccessFlag(..) )
93 import TidyPgm    ( globaliseAndTidyId )
94 import TysWiredIn ( unitTy, mkListTy )
95 #endif
96
97 import FastString
98 import Maybes
99 import Util
100 import Bag
101
102 import Control.Monad
103
104 #include "HsVersions.h"
105 \end{code}
106
107 %************************************************************************
108 %*                                                                      *
109         Typecheck and rename a module
110 %*                                                                      *
111 %************************************************************************
112
113
114 \begin{code}
115 -- | Top level entry point for typechecker and renamer
116 tcRnModule :: HscEnv
117            -> HscSource
118            -> Bool              -- True <=> save renamed syntax
119            -> HsParsedModule
120            -> IO (Messages, Maybe TcGblEnv)
121
122 tcRnModule hsc_env hsc_src save_rn_syntax
123    parsedModule@HsParsedModule {hpm_module=L loc this_module}
124  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
125
126    let { this_pkg = thisPackage (hsc_dflags hsc_env) ;
127          pair@(this_mod,_)
128             = case hsmodName this_module of
129                 Nothing -- 'module M where' is omitted
130                     ->  (mAIN, srcLocSpan (srcSpanStart loc))
131
132                 Just (L mod_loc mod)  -- The normal case
133                     -> (mkModule this_pkg mod, mod_loc) } ;
134
135    initTc hsc_env hsc_src save_rn_syntax this_mod $
136      tcRnModuleTcRnM hsc_env hsc_src parsedModule pair }
137
138 tcRnModuleTcRnM :: HscEnv
139                 -> HscSource
140                 -> HsParsedModule
141                 -> (Module, SrcSpan)
142                 -> TcRn TcGblEnv
143 tcRnModuleTcRnM hsc_env hsc_src
144    (HsParsedModule {
145       hpm_module =
146          (L loc (HsModule maybe_mod export_ies
147                           import_decls local_decls mod_deprec
148                           maybe_doc_hdr)),
149       hpm_src_files =
150          src_files
151    })
152    (this_mod, prel_imp_loc) =
153    setSrcSpan loc $
154    do {         -- Deal with imports; first add implicit prelude
155         implicit_prelude <- xoptM Opt_ImplicitPrelude;
156         let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc
157                                          implicit_prelude import_decls } ;
158
159         whenWOptM Opt_WarnImplicitPrelude $
160              when (notNull prel_imports) $ addWarn (implicitPreludeWarn) ;
161
162         tcg_env <- {-# SCC "tcRnImports" #-}
163                    tcRnImports hsc_env this_mod (prel_imports ++ import_decls) ;
164
165           -- If the whole module is warned about or deprecated 
166           -- (via mod_deprec) record that in tcg_warns. If we do thereby add
167           -- a WarnAll, it will override any subseqent depracations added to tcg_warns
168         let { tcg_env1 = case mod_deprec of 
169                          Just txt -> tcg_env { tcg_warns = WarnAll txt } 
170                          Nothing  -> tcg_env 
171             } ;
172  
173         setGblEnv tcg_env1 $ do {
174
175                 -- Load the hi-boot interface for this module, if any
176                 -- We do this now so that the boot_names can be passed
177                 -- to tcTyAndClassDecls, because the boot_names are
178                 -- automatically considered to be loop breakers
179                 --
180                 -- Do this *after* tcRnImports, so that we know whether
181                 -- a module that we import imports us; and hence whether to
182                 -- look for a hi-boot file
183         boot_iface <- tcHiBootIface hsc_src this_mod ;
184
185                 -- Rename and type check the declarations
186         traceRn (text "rn1a") ;
187         tcg_env <- if isHsBoot hsc_src then
188                         tcRnHsBootDecls local_decls
189                    else
190                         {-# SCC "tcRnSrcDecls" #-}
191                         tcRnSrcDecls boot_iface local_decls ;
192         setGblEnv tcg_env               $ do {
193
194                 -- Process the export list
195         traceRn (text "rn4a: before exports");
196         tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ;
197         traceRn (text "rn4b: after exports") ;
198
199                 -- Check that main is exported (must be after rnExports)
200         checkMainExported tcg_env ;
201
202         -- Compare the hi-boot iface (if any) with the real thing
203         -- Must be done after processing the exports
204         tcg_env <- checkHiBootIface tcg_env boot_iface ;
205
206         -- The new type env is already available to stuff slurped from
207         -- interface files, via TcEnv.updateGlobalTypeEnv
208         -- It's important that this includes the stuff in checkHiBootIface,
209         -- because the latter might add new bindings for boot_dfuns,
210         -- which may be mentioned in imported unfoldings
211
212                 -- Don't need to rename the Haddock documentation,
213                 -- it's not parsed by GHC anymore.
214         tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ;
215
216                 -- Report unused names
217         reportUnusedNames export_ies tcg_env ;
218
219                 -- add extra source files to tcg_dependent_files
220         addDependentFiles src_files ;
221
222                 -- Dump output and return
223         tcDump tcg_env ;
224         return tcg_env
225     }}}
226
227
228 implicitPreludeWarn :: SDoc
229 implicitPreludeWarn
230   = ptext (sLit "Module `Prelude' implicitly imported")
231 \end{code}
232
233
234 %************************************************************************
235 %*                                                                      *
236                 Import declarations
237 %*                                                                      *
238 %************************************************************************
239
240 \begin{code}
241 tcRnImports :: HscEnv -> Module
242             -> [LImportDecl RdrName] -> TcM TcGblEnv
243 tcRnImports hsc_env this_mod import_decls
244   = do  { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ;
245
246         ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
247                 -- Make sure we record the dependencies from the DynFlags in the EPS or we
248                 -- end up hitting the sanity check in LoadIface.loadInterface that
249                 -- checks for unknown home-package modules being loaded. We put
250                 -- these dependencies on the left so their (non-source) imports
251                 -- take precedence over the (possibly-source) imports on the right.
252                 -- We don't add them to any other field (e.g. the imp_dep_mods of
253                 -- imports) because we don't want to load their instances etc.
254               ; dep_mods = listToUFM [(mod_nm, (mod_nm, False)) | mod_nm <- dynFlagDependencies (hsc_dflags hsc_env)]
255                                 `plusUFM` imp_dep_mods imports
256
257                 -- We want instance declarations from all home-package
258                 -- modules below this one, including boot modules, except
259                 -- ourselves.  The 'except ourselves' is so that we don't
260                 -- get the instances from this module's hs-boot file.  This
261                 -- filtering also ensures that we don't see instances from
262                 -- modules batch (@--make@) compiled before this one, but
263                 -- which are not below this one.
264               ; want_instances :: ModuleName -> Bool
265               ; want_instances mod = mod `elemUFM` dep_mods
266                                    && mod /= moduleName this_mod
267               ; (home_insts, home_fam_insts) = hptInstances hsc_env
268                                                             want_instances
269               } ;
270
271                 -- Record boot-file info in the EPS, so that it's
272                 -- visible to loadHiBootInterface in tcRnSrcDecls,
273                 -- and any other incrementally-performed imports
274         ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
275
276                 -- Update the gbl env
277         ; updGblEnv ( \ gbl ->
278             gbl {
279               tcg_rdr_env      = plusOccEnv (tcg_rdr_env gbl) rdr_env,
280               tcg_imports      = tcg_imports gbl `plusImportAvails` imports,
281               tcg_rn_imports   = rn_imports,
282               tcg_inst_env     = extendInstEnvList (tcg_inst_env gbl) home_insts,
283               tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
284                                                       home_fam_insts,
285               tcg_hpc          = hpc_info
286             }) $ do {
287
288         ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports))
289                 -- Fail if there are any errors so far
290                 -- The error printing (if needed) takes advantage
291                 -- of the tcg_env we have now set
292 --      ; traceIf (text "rdr_env: " <+> ppr rdr_env)
293         ; failIfErrsM
294
295                 -- Load any orphan-module and family instance-module
296                 -- interfaces, so that their rules and instance decls will be
297                 -- found.
298         ; loadModuleInterfaces (ptext (sLit "Loading orphan modules"))
299                                (imp_orphs imports)
300
301                 -- Check type-family consistency
302         ; traceRn (text "rn1: checking family instance consistency")
303         ; let { dir_imp_mods = moduleEnvKeys
304                              . imp_mods
305                              $ imports }
306         ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ;
307
308         ; getGblEnv } }
309 \end{code}
310
311
312 %************************************************************************
313 %*                                                                      *
314         Type-checking external-core modules
315 %*                                                                      *
316 %************************************************************************
317
318 \begin{code}
319 tcRnExtCore :: HscEnv
320             -> HsExtCore RdrName
321             -> IO (Messages, Maybe ModGuts)
322         -- Nothing => some error occurred
323
324 tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
325         -- The decls are IfaceDecls; all names are original names
326  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
327
328    initTc hsc_env ExtCoreFile False this_mod $ do {
329
330    let { ldecls  = map noLoc decls } ;
331
332        -- Bring the type and class decls into scope
333        -- ToDo: check that this doesn't need to extract the val binds.
334        --       It seems that only the type and class decls need to be in scope below because
335        --          (a) tcTyAndClassDecls doesn't need the val binds, and
336        --          (b) tcExtCoreBindings doesn't need anything
337        --              (in fact, it might not even need to be in the scope of
338        --               this tcg_env at all)
339    (tc_envs, _bndrs) <- getLocalNonValBinders emptyFsEnv {- no fixity decls -}
340                                               (mkFakeGroup ldecls) ;
341    setEnvs tc_envs $ do {
342
343    (rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls [] [mkTyClGroup ldecls] ;
344    -- The empty list is for extra dependencies coming from .hs-boot files
345    -- See Note [Extra dependencies from .hs-boot files] in RnSource
346
347         -- Dump trace of renaming part
348    rnDump (ppr rn_decls) ;
349
350         -- Typecheck them all together so that
351         -- any mutually recursive types are done right
352         -- Just discard the auxiliary bindings; they are generated
353         -- only for Haskell source code, and should already be in Core
354    tcg_env   <- tcTyAndClassDecls emptyModDetails rn_decls ;
355    safe_mode <- liftIO $ finalSafeMode (hsc_dflags hsc_env) tcg_env ;
356    dep_files <- liftIO $ readIORef (tcg_dependent_files tcg_env) ;
357
358    setGblEnv tcg_env $ do {
359         -- Make the new type env available to stuff slurped from interface files
360
361         -- Now the core bindings
362    core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
363
364
365         -- Wrap up
366    let {
367         bndrs      = bindersOfBinds core_binds ;
368         my_exports = map (Avail . idName) bndrs ;
369                 -- ToDo: export the data types also?
370
371         mod_guts = ModGuts {    mg_module    = this_mod,
372                                 mg_boot      = False,
373                                 mg_used_names = emptyNameSet, -- ToDo: compute usage
374                                 mg_used_th   = False,
375                                 mg_dir_imps  = emptyModuleEnv, -- ??
376                                 mg_deps      = noDependencies,  -- ??
377                                 mg_exports   = my_exports,
378                                 mg_tcs       = tcg_tcs tcg_env,
379                                 mg_insts     = tcg_insts tcg_env,
380                                 mg_fam_insts = tcg_fam_insts tcg_env,
381                                 mg_inst_env  = tcg_inst_env tcg_env,
382                                 mg_fam_inst_env = tcg_fam_inst_env tcg_env,
383                                 mg_rules        = [],
384                                 mg_vect_decls   = [],
385                                 mg_anns         = [],
386                                 mg_binds        = core_binds,
387
388                                 -- Stubs
389                                 mg_rdr_env      = emptyGlobalRdrEnv,
390                                 mg_fix_env      = emptyFixityEnv,
391                                 mg_warns        = NoWarnings,
392                                 mg_foreign      = NoStubs,
393                                 mg_hpc_info     = emptyHpcInfo False,
394                                 mg_modBreaks    = emptyModBreaks,
395                                 mg_vect_info    = noVectInfo,
396                                 mg_safe_haskell = safe_mode,
397                                 mg_trust_pkg    = False,
398                                 mg_dependent_files = dep_files
399                             } } ;
400
401    tcCoreDump mod_guts ;
402
403    return mod_guts
404    }}}}
405
406 mkFakeGroup :: [LTyClDecl a] -> HsGroup a
407 mkFakeGroup decls -- Rather clumsy; lots of unused fields
408   = emptyRdrGroup { hs_tyclds = [mkTyClGroup decls] }
409 \end{code}
410
411
412 %************************************************************************
413 %*                                                                      *
414         Type-checking the top level of a module
415 %*                                                                      *
416 %************************************************************************
417
418 \begin{code}
419 tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv
420         -- Returns the variables free in the decls
421         -- Reason: solely to report unused imports and bindings
422 tcRnSrcDecls boot_iface decls
423  = do {         -- Do all the declarations
424         ((tcg_env, tcl_env), lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ;
425       ; traceTc "Tc8" empty ;
426       ; setEnvs (tcg_env, tcl_env) $
427    do {
428
429              --         Finish simplifying class constraints
430              --
431              -- simplifyTop deals with constant or ambiguous InstIds.
432              -- How could there be ambiguous ones?  They can only arise if a
433              -- top-level decl falls under the monomorphism restriction
434              -- and no subsequent decl instantiates its type.
435              --
436              -- We do this after checkMain, so that we use the type info
437              -- that checkMain adds
438              --
439              -- We do it with both global and local env in scope:
440              --  * the global env exposes the instances to simplifyTop
441              --  * the local env exposes the local Ids to simplifyTop,
442              --    so that we get better error messages (monomorphism restriction)
443         new_ev_binds <- {-# SCC "simplifyTop" #-}
444                         simplifyTop lie ;
445         traceTc "Tc9" empty ;
446
447         failIfErrsM ;   -- Don't zonk if there have been errors
448                         -- It's a waste of time; and we may get debug warnings
449                         -- about strangely-typed TyCons!
450
451         -- Zonk the final code.  This must be done last.
452         -- Even simplifyTop may do some unification.
453         -- This pass also warns about missing type signatures
454         let { TcGblEnv { tcg_type_env  = type_env,
455                          tcg_binds     = binds,
456                          tcg_sigs      = sig_ns,
457                          tcg_ev_binds  = cur_ev_binds,
458                          tcg_imp_specs = imp_specs,
459                          tcg_rules     = rules,
460                          tcg_vects     = vects,
461                          tcg_fords     = fords } = tcg_env
462             ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
463
464         (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
465             <- {-# SCC "zonkTopDecls" #-}
466                zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords ;
467
468         let { final_type_env = extendTypeEnvWithIds type_env bind_ids
469             ; tcg_env' = tcg_env { tcg_binds    = binds',
470                                    tcg_ev_binds = ev_binds',
471                                    tcg_imp_specs = imp_specs',
472                                    tcg_rules    = rules',
473                                    tcg_vects    = vects',
474                                    tcg_fords    = fords' } } ;
475
476         setGlobalTypeEnv tcg_env' final_type_env
477        
478    } }
479
480 tc_rn_src_decls :: ModDetails
481                 -> [LHsDecl RdrName]
482                 -> TcM (TcGblEnv, TcLclEnv)
483 -- Loops around dealing with each top level inter-splice group
484 -- in turn, until it's dealt with the entire module
485 tc_rn_src_decls boot_details ds
486  = {-# SCC "tc_rn_src_decls" #-}
487    do { (first_group, group_tail) <- findSplice ds
488                 -- If ds is [] we get ([], Nothing)
489
490         -- The extra_deps are needed while renaming type and class declarations
491         -- See Note [Extra dependencies from .hs-boot files] in RnSource
492       ; let { extra_deps = map tyConName (typeEnvTyCons (md_types boot_details)) }
493         -- Deal with decls up to, but not including, the first splice
494       ; (tcg_env, rn_decls) <- rnTopSrcDecls extra_deps first_group
495                 -- rnTopSrcDecls fails if there are any errors
496
497 #ifdef GHCI
498         -- Get TH-generated top-level declarations and make sure they don't
499         -- contain any splices since we don't handle that at the moment
500       ; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv
501       ; th_ds <- readTcRef th_topdecls_var
502       ; writeTcRef th_topdecls_var []
503
504       ; (tcg_env, rn_decls) <-
505             if null th_ds
506             then return (tcg_env, rn_decls)
507             else do { (th_group, th_group_tail) <- findSplice th_ds
508                     ; case th_group_tail of
509                         { Nothing -> return () ;
510                         ; Just (SpliceDecl (L loc _) _, _)
511                             -> setSrcSpan loc $
512                                addErr (ptext (sLit "Declaration splices are not permitted inside top-level declarations added with addTopDecls"))
513                         } ;
514                                          
515                     -- Rename TH-generated top-level declarations
516                     ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env $
517                       rnTopSrcDecls extra_deps th_group
518
519                     -- Dump generated top-level declarations
520                     ; loc <- getSrcSpanM
521                     ; traceSplice (vcat [ppr loc <> colon <+> text "Splicing top-level declarations added with addTopDecls ",
522                                    nest 2 (nest 2 (ppr th_rn_decls))])
523
524                     ; return (tcg_env, appendGroups rn_decls th_rn_decls)
525                     }
526 #endif /* GHCI */
527
528       -- Type check all declarations
529       ; (tcg_env, tcl_env) <- setGblEnv tcg_env $
530                               tcTopSrcDecls boot_details rn_decls
531
532         -- If there is no splice, we're nearly done
533       ; setEnvs (tcg_env, tcl_env) $
534         case group_tail of
535           { Nothing -> do { tcg_env <- checkMain       -- Check for `main'
536                           ; traceTc "returning from tc_rn_src_decls: " $
537                             ppr $ nameEnvElts $ tcg_type_env tcg_env -- RAE
538 #ifdef GHCI
539                             -- Run all module finalizers
540                           ; th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
541                           ; modfinalizers <- readTcRef th_modfinalizers_var
542                           ; writeTcRef th_modfinalizers_var []
543                           ; mapM_ runQuasi modfinalizers
544 #endif /* GHCI */
545                           ; return (tcg_env, tcl_env)
546                           }
547
548 #ifndef GHCI
549             -- There shouldn't be a splice
550           ; Just (SpliceDecl {}, _) ->
551             failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
552           }
553 #else
554             -- If there's a splice, we must carry on
555           ; Just (SpliceDecl (L _ splice) _, rest_ds) ->
556             do { -- Rename the splice expression, and get its supporting decls
557                  (rn_splice, splice_fvs) <- checkNoErrs (rnSplice splice)
558                  -- checkNoErrs: don't typecheck if renaming failed
559                ; rnDump (ppr rn_splice)
560
561                  -- Execute the splice
562                ; spliced_decls <- tcSpliceDecls rn_splice
563
564                  -- Glue them on the front of the remaining decls and loop
565                ; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
566                  tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
567                }
568           }
569 #endif /* GHCI */
570       }
571 \end{code}
572
573 %************************************************************************
574 %*                                                                      *
575         Compiling hs-boot source files, and
576         comparing the hi-boot interface with the real thing
577 %*                                                                      *
578 %************************************************************************
579
580 \begin{code}
581 tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
582 tcRnHsBootDecls decls
583    = do { (first_group, group_tail) <- findSplice decls
584
585                 -- Rename the declarations
586         ; (tcg_env, HsGroup {
587                    hs_tyclds = tycl_decls,
588                    hs_instds = inst_decls,
589                    hs_derivds = deriv_decls,
590                    hs_fords  = for_decls,
591                    hs_defds  = def_decls,
592                    hs_ruleds = rule_decls,
593                    hs_vects  = vect_decls,
594                    hs_annds  = _,
595                    hs_valds  = val_binds }) <- rnTopSrcDecls [] first_group
596         -- The empty list is for extra dependencies coming from .hs-boot files
597         -- See Note [Extra dependencies from .hs-boot files] in RnSource
598         ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {
599
600
601                 -- Check for illegal declarations
602         ; case group_tail of
603              Just (SpliceDecl d _, _) -> badBootDecl "splice" d
604              Nothing                  -> return ()
605         ; mapM_ (badBootDecl "foreign") for_decls
606         ; mapM_ (badBootDecl "default") def_decls
607         ; mapM_ (badBootDecl "rule")    rule_decls
608         ; mapM_ (badBootDecl "vect")    vect_decls
609
610                 -- Typecheck type/class/isntance decls
611         ; traceTc "Tc2 (boot)" empty
612         ; (tcg_env, inst_infos, _deriv_binds)
613              <- tcTyClsInstDecls emptyModDetails tycl_decls inst_decls deriv_decls
614         ; setGblEnv tcg_env     $ do {
615
616                 -- Typecheck value declarations
617         ; traceTc "Tc5" empty
618         ; val_ids <- tcHsBootSigs val_binds
619
620                 -- Wrap up
621                 -- No simplification or zonking to do
622         ; traceTc "Tc7a" empty
623         ; gbl_env <- getGblEnv
624
625                 -- Make the final type-env
626                 -- Include the dfun_ids so that their type sigs
627                 -- are written into the interface file.
628         ; let { type_env0 = tcg_type_env gbl_env
629               ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
630               ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids
631               ; dfun_ids = map iDFunId inst_infos
632               }
633
634         ; setGlobalTypeEnv gbl_env type_env2
635    }}
636    ; traceTc "boot" (ppr lie); return gbl_env }
637
638 badBootDecl :: String -> Located decl -> TcM ()
639 badBootDecl what (L loc _)
640   = addErrAt loc (char 'A' <+> text what
641       <+> ptext (sLit "declaration is not (currently) allowed in a hs-boot file"))
642 \end{code}
643
644 Once we've typechecked the body of the module, we want to compare what
645 we've found (gathered in a TypeEnv) with the hi-boot details (if any).
646
647 \begin{code}
648 checkHiBootIface :: TcGblEnv -> ModDetails -> TcM TcGblEnv
649 -- Compare the hi-boot file for this module (if there is one)
650 -- with the type environment we've just come up with
651 -- In the common case where there is no hi-boot file, the list
652 -- of boot_names is empty.
653 --
654 -- The bindings we return give bindings for the dfuns defined in the
655 -- hs-boot file, such as        $fbEqT = $fEqT
656
657 checkHiBootIface
658         tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds,
659                             tcg_insts = local_insts,
660                             tcg_type_env = local_type_env, tcg_exports = local_exports })
661         (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
662                       md_types = boot_type_env, md_exports = boot_exports })
663   | isHsBoot hs_src     -- Current module is already a hs-boot file!
664   = return tcg_env
665
666   | otherwise
667   = do  { traceTc "checkHiBootIface" $ vcat
668              [ ppr boot_type_env, ppr boot_insts, ppr boot_exports]
669
670                 -- Check the exports of the boot module, one by one
671         ; mapM_ check_export boot_exports
672
673                 -- Check for no family instances
674         ; unless (null boot_fam_insts) $
675             panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
676                    "instances in boot files yet...")
677             -- FIXME: Why?  The actual comparison is not hard, but what would
678             --        be the equivalent to the dfun bindings returned for class
679             --        instances?  We can't easily equate tycons...
680
681                 -- Check instance declarations
682         ; mb_dfun_prs <- mapM check_inst boot_insts
683         ; let dfun_prs   = catMaybes mb_dfun_prs
684               boot_dfuns = map fst dfun_prs
685               dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
686                                      | (boot_dfun, dfun) <- dfun_prs ]
687               type_env'  = extendTypeEnvWithIds local_type_env boot_dfuns
688               tcg_env'   = tcg_env { tcg_binds = binds `unionBags` dfun_binds }
689
690         ; failIfErrsM
691         ; setGlobalTypeEnv tcg_env' type_env' }
692              -- Update the global type env *including* the knot-tied one
693              -- so that if the source module reads in an interface unfolding
694              -- mentioning one of the dfuns from the boot module, then it
695              -- can "see" that boot dfun.   See Trac #4003
696   where
697     check_export boot_avail     -- boot_avail is exported by the boot iface
698       | name `elem` dfun_names = return ()
699       | isWiredInName name     = return ()      -- No checking for wired-in names.  In particular,
700                                                 -- 'error' is handled by a rather gross hack
701                                                 -- (see comments in GHC.Err.hs-boot)
702
703         -- Check that the actual module exports the same thing
704       | not (null missing_names)
705       = addErrAt (nameSrcSpan (head missing_names))
706                  (missingBootThing (head missing_names) "exported by")
707
708         -- If the boot module does not *define* the thing, we are done
709         -- (it simply re-exports it, and names match, so nothing further to do)
710       | isNothing mb_boot_thing = return ()
711
712         -- Check that the actual module also defines the thing, and
713         -- then compare the definitions
714       | Just real_thing <- lookupTypeEnv local_type_env name,
715         Just boot_thing <- mb_boot_thing
716       = when (not (checkBootDecl boot_thing real_thing))
717             $ addErrAt (nameSrcSpan (getName boot_thing))
718                        (bootMisMatch real_thing boot_thing)
719
720       | otherwise
721       = addErrTc (missingBootThing name "defined in")
722       where
723         name          = availName boot_avail
724         mb_boot_thing = lookupTypeEnv boot_type_env name
725         missing_names = case lookupNameEnv local_export_env name of
726                           Nothing    -> [name]
727                           Just avail -> availNames boot_avail `minusList` availNames avail
728
729     dfun_names = map getName boot_insts
730
731     local_export_env :: NameEnv AvailInfo
732     local_export_env = availsToNameEnv local_exports
733
734     check_inst :: ClsInst -> TcM (Maybe (Id, Id))
735         -- Returns a pair of the boot dfun in terms of the equivalent real dfun
736     check_inst boot_inst
737         = case [dfun | inst <- local_insts,
738                        let dfun = instanceDFunId inst,
739                        idType dfun `eqType` boot_inst_ty ] of
740             [] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts)
741                                                   , text "boot_inst"   <+> ppr boot_inst
742                                                   , text "boot_inst_ty" <+> ppr boot_inst_ty
743                                                   ])
744                      ; addErrTc (instMisMatch boot_inst); return Nothing }
745             (dfun:_) -> return (Just (local_boot_dfun, dfun))
746         where
747           boot_dfun = instanceDFunId boot_inst
748           boot_inst_ty = idType boot_dfun
749           local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty
750
751
752 -- This has to compare the TyThing from the .hi-boot file to the TyThing
753 -- in the current source file.  We must be careful to allow alpha-renaming
754 -- where appropriate, and also the boot declaration is allowed to omit
755 -- constructors and class methods.
756 --
757 -- See rnfail055 for a good test of this stuff.
758
759 checkBootDecl :: TyThing -> TyThing -> Bool
760
761 checkBootDecl (AnId id1) (AnId id2)
762   = ASSERT(id1 == id2)
763     (idType id1 `eqType` idType id2)
764
765 checkBootDecl (ATyCon tc1) (ATyCon tc2)
766   = checkBootTyCon tc1 tc2
767
768 checkBootDecl (ADataCon dc1) (ADataCon _)
769   = pprPanic "checkBootDecl" (ppr dc1)
770
771 checkBootDecl _ _ = False -- probably shouldn't happen
772
773 ----------------
774 checkBootTyCon :: TyCon -> TyCon -> Bool
775 checkBootTyCon tc1 tc2
776   | not (eqKind (tyConKind tc1) (tyConKind tc2))
777   = False       -- First off, check the kind
778
779   | Just c1 <- tyConClass_maybe tc1
780   , Just c2 <- tyConClass_maybe tc2
781   , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1)
782           = classExtraBigSig c1
783         (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2)
784           = classExtraBigSig c2
785   , Just env <- eqTyVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2
786   = let
787        eqSig (id1, def_meth1) (id2, def_meth2)
788          = idName id1 == idName id2 &&
789            eqTypeX env op_ty1 op_ty2 &&
790            def_meth1 == def_meth2
791          where
792           (_, rho_ty1) = splitForAllTys (idType id1)
793           op_ty1 = funResultTy rho_ty1
794           (_, rho_ty2) = splitForAllTys (idType id2)
795           op_ty2 = funResultTy rho_ty2
796
797        eqAT (tc1, def_ats1) (tc2, def_ats2)
798          = checkBootTyCon tc1 tc2 &&
799            eqListBy eqATDef def_ats1 def_ats2
800
801        -- Ignore the location of the defaults
802        eqATDef (CoAxBranch { cab_tvs = tvs1, cab_lhs =  ty_pats1, cab_rhs = ty1 })
803                (CoAxBranch { cab_tvs = tvs2, cab_lhs =  ty_pats2, cab_rhs = ty2 })
804          | Just env <- eqTyVarBndrs emptyRnEnv2 tvs1 tvs2
805          = eqListBy (eqTypeX env) ty_pats1 ty_pats2 &&
806            eqTypeX env ty1 ty2
807          | otherwise = False
808
809        eqFD (as1,bs1) (as2,bs2) =
810          eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
811          eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
812     in
813        roles1 == roles2 &&
814              -- Checks kind of class
815        eqListBy eqFD clas_fds1 clas_fds2 &&
816        (null sc_theta1 && null op_stuff1 && null ats1
817         ||   -- Above tests for an "abstract" class
818         eqListBy (eqPredX env) sc_theta1 sc_theta2 &&
819         eqListBy eqSig op_stuff1 op_stuff2 &&
820         eqListBy eqAT ats1 ats2)
821
822   | Just syn_rhs1 <- synTyConRhs_maybe tc1
823   , Just syn_rhs2 <- synTyConRhs_maybe tc2
824   , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
825   = ASSERT(tc1 == tc2)
826     let eqSynRhs OpenSynFamilyTyCon OpenSynFamilyTyCon = True
827         eqSynRhs AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True
828         eqSynRhs (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True
829         eqSynRhs (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2)
830             = eqClosedFamilyAx ax1 ax2
831         eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
832             = eqTypeX env t1 t2
833         eqSynRhs (BuiltInSynFamTyCon _) (BuiltInSynFamTyCon _) = tc1 == tc2
834         eqSynRhs _ _ = False
835     in
836     roles1 == roles2 &&
837     eqSynRhs syn_rhs1 syn_rhs2
838
839   | isAlgTyCon tc1 && isAlgTyCon tc2
840   , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
841   = ASSERT(tc1 == tc2)
842     roles1 == roles2 &&
843     eqListBy (eqPredX env) (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
844     eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)
845
846   | isForeignTyCon tc1 && isForeignTyCon tc2
847   = eqKind (tyConKind tc1) (tyConKind tc2) &&
848     tyConExtName tc1 == tyConExtName tc2
849
850   | otherwise = False
851   where
852     roles1 = tyConRoles tc1
853     roles2 = tyConRoles tc2
854
855     eqAlgRhs (AbstractTyCon dis1) rhs2
856       | dis1      = isDistinctAlgRhs rhs2   --Check compatibility
857       | otherwise = True
858     eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True
859     eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} =
860         eqListBy eqCon (data_cons tc1) (data_cons tc2)
861     eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} =
862         eqCon (data_con tc1) (data_con tc2)
863     eqAlgRhs _ _ = False
864
865     eqCon c1 c2
866       =  dataConName c1 == dataConName c2
867       && dataConIsInfix c1 == dataConIsInfix c2
868       && eqListBy eqHsBang (dataConStrictMarks c1) (dataConStrictMarks c2)
869       && dataConFieldLabels c1 == dataConFieldLabels c2
870       && eqType (dataConUserType c1) (dataConUserType c2)
871
872     eqClosedFamilyAx (CoAxiom { co_ax_branches = branches1 })
873                      (CoAxiom { co_ax_branches = branches2 })
874       =  brListLength branches1 == brListLength branches2
875       && (and $ brListZipWith eqClosedFamilyBranch branches1 branches2)
876
877     eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_lhs = lhs1, cab_rhs = rhs1 })
878                          (CoAxBranch { cab_tvs = tvs2, cab_lhs = lhs2, cab_rhs = rhs2 })
879       | Just env <- eqTyVarBndrs emptyRnEnv2 tvs1 tvs2
880       = eqListBy (eqTypeX env) lhs1 lhs2 &&
881         eqTypeX env rhs1 rhs2
882
883       | otherwise = False
884
885 emptyRnEnv2 :: RnEnv2
886 emptyRnEnv2 = mkRnEnv2 emptyInScopeSet
887
888 ----------------
889 missingBootThing :: Name -> String -> SDoc
890 missingBootThing name what
891   = ppr name <+> ptext (sLit "is exported by the hs-boot file, but not")
892               <+> text what <+> ptext (sLit "the module")
893
894 bootMisMatch :: TyThing -> TyThing -> SDoc
895 bootMisMatch real_thing boot_thing
896   = vcat [ppr real_thing <+>
897           ptext (sLit "has conflicting definitions in the module"),
898           ptext (sLit "and its hs-boot file"),
899           ptext (sLit "Main module:") <+> PprTyThing.pprTyThing real_thing,
900           ptext (sLit "Boot file:  ") <+> PprTyThing.pprTyThing boot_thing]
901
902 instMisMatch :: ClsInst -> SDoc
903 instMisMatch inst
904   = hang (ppr inst)
905        2 (ptext (sLit "is defined in the hs-boot file, but not in the module itself"))
906 \end{code}
907
908
909 %************************************************************************
910 %*                                                                      *
911         Type-checking the top level of a module
912 %*                                                                      *
913 %************************************************************************
914
915 tcRnGroup takes a bunch of top-level source-code declarations, and
916  * renames them
917  * gets supporting declarations from interface files
918  * typechecks them
919  * zonks them
920  * and augments the TcGblEnv with the results
921
922 In Template Haskell it may be called repeatedly for each group of
923 declarations.  It expects there to be an incoming TcGblEnv in the
924 monad; it augments it and returns the new TcGblEnv.
925
926 \begin{code}
927 ------------------------------------------------
928 rnTopSrcDecls :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
929 -- Fails if there are any errors
930 rnTopSrcDecls extra_deps group
931  = do { -- Rename the source decls
932         traceTc "rn12" empty ;
933         (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls extra_deps group ;
934         traceTc "rn13" empty ;
935
936         -- save the renamed syntax, if we want it
937         let { tcg_env'
938                 | Just grp <- tcg_rn_decls tcg_env
939                   = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
940                 | otherwise
941                    = tcg_env };
942
943                 -- Dump trace of renaming part
944         rnDump (ppr rn_decls) ;
945
946         return (tcg_env', rn_decls)
947    }
948 \end{code}
949
950
951 %************************************************************************
952 %*                                                                      *
953                 AMP warnings
954      The functions defined here issue warnings according to 
955      the 2013 Applicative-Monad proposal. (Trac #8004)
956 %*                                                                      *
957 %************************************************************************
958
959 \begin{code}
960 -- | Main entry point for generating AMP warnings
961 tcAmpWarn :: TcM ()
962 tcAmpWarn =
963     do { warnFlag <- woptM Opt_WarnAMP
964        ; when warnFlag $ do {
965
966          -- Monad without Applicative
967        ; tcAmpMissingParentClassWarn monadClassName
968                                      applicativeClassName
969
970          -- MonadPlus without Alternative
971        ; tcAmpMissingParentClassWarn monadPlusClassName
972                                      alternativeClassName
973
974          -- Custom local definitions of join/pure/<*>
975        ; mapM_ tcAmpFunctionWarn [joinMName, apAName, pureAName]
976     }}
977
978
979
980 -- | Warn on local definitions of names that would clash with Prelude versions,
981 --   i.e. join/pure/<*>
982 --
983 --   A name clashes if the following criteria are met:
984 --       1. It would is imported (unqualified) from Prelude
985 --       2. It is locally defined in the current module
986 --       3. It has the same literal name as the reference function
987 --       4. It is not identical to the reference function
988 tcAmpFunctionWarn :: Name -- ^ Name to check, e.g. joinMName for join
989                   -> TcM ()
990 tcAmpFunctionWarn name = do
991     { traceTc "tcAmpFunctionWarn/wouldBeImported" empty
992     -- Is the name imported (unqualified) from Prelude? (Point 4 above)
993     ; rnImports <- fmap (map unLoc . tcg_rn_imports) getGblEnv
994     -- (Note that this automatically handles -XNoImplicitPrelude, as Prelude
995     -- will not appear in rnImports automatically if it is set.)
996
997     -- Continue only the name is imported from Prelude
998     ; when (tcAmpImportViaPrelude name rnImports) $ do
999       -- Handle 2.-4.
1000     { rdrElts <- fmap (concat . occEnvElts . tcg_rdr_env) getGblEnv
1001
1002     ; let clashes :: GlobalRdrElt -> Bool
1003           clashes x = and [ gre_prov x == LocalDef
1004                           , nameOccName (gre_name x) == nameOccName name
1005                           , gre_name x /= name
1006                           ]
1007
1008           -- List of all offending definitions
1009           clashingElts :: [GlobalRdrElt]
1010           clashingElts = filter clashes rdrElts
1011
1012     ; traceTc "tcAmpFunctionWarn/amp_prelude_functions"
1013                 (hang (ppr name) 4 (sep [ppr clashingElts]))
1014
1015     ; let warn_msg x = addWarnAt (nameSrcSpan $ gre_name x) . hsep $
1016               [ ptext (sLit "Local definition of")
1017               , quotes . ppr . nameOccName $ gre_name x
1018               , ptext (sLit "clashes with a future Prelude name")
1019               , ptext (sLit "- this will become an error in GHC 7.10,")
1020               , ptext (sLit "under the Applicative-Monad Proposal.")
1021               ]
1022     ; mapM_ warn_msg clashingElts
1023     }}
1024
1025 -- | Is the given name imported via Prelude?
1026 --
1027 --   This function makes sure that e.g. "import Prelude (map)" should silence
1028 --   AMP warnings about "join" even when they are locally defined.
1029 --
1030 --   Possible scenarios:
1031 --     a) Prelude is imported implicitly, issue warnings.
1032 --     b) Prelude is imported explicitly, but without mentioning the name in
1033 --        question. Issue no warnings.
1034 --     c) Prelude is imported hiding the name in question. Issue no warnings.
1035 --     d) Qualified import of Prelude, no warnings.
1036 tcAmpImportViaPrelude :: Name
1037                       -> [ImportDecl Name]
1038                       -> Bool
1039 tcAmpImportViaPrelude name = any importViaPrelude
1040   where
1041     isPrelude :: ImportDecl Name -> Bool
1042     isPrelude imp = unLoc (ideclName imp) == pRELUDE_NAME
1043
1044     -- Implicit (Prelude) import?
1045     isImplicit :: ImportDecl Name -> Bool
1046     isImplicit = ideclImplicit
1047
1048     -- Unqualified import?
1049     isUnqualified :: ImportDecl Name -> Bool
1050     isUnqualified = not . ideclQualified
1051
1052     second :: (a -> b) -> (x, a) -> (x, b)
1053     second f (x, y) = (x, f y)
1054
1055     -- List of explicitly imported (or hidden) Names from a single import.
1056     --   Nothing -> No explicit imports
1057     --   Just (False, <names>) -> Explicit import list of <names>
1058     --   Just (True , <names>) -> Explicit hiding of <names>
1059     importList :: ImportDecl Name -> Maybe (Bool, [Name])
1060     importList = fmap (second (map (ieName . unLoc))) . ideclHiding
1061
1062     -- Check whether the given name would be imported (unqualified) from
1063     -- an import declaration.
1064     importViaPrelude :: ImportDecl Name -> Bool
1065     importViaPrelude x = isPrelude x && isUnqualified x && or [
1066         -- Whole Prelude imported -> potential clash
1067           isImplicit x
1068         -- Explicit import/hiding list, if applicable
1069         , case importList x of
1070             Just (False, explicit) -> nameOccName name `elem`    map nameOccName explicit
1071             Just (True , hidden  ) -> nameOccName name `notElem` map nameOccName hidden
1072             Nothing                -> False
1073         ]
1074
1075 -- | Issue a warning for instance definitions lacking a should-be parent class.
1076 --   Used for Monad without Applicative and MonadPlus without Alternative.
1077 tcAmpMissingParentClassWarn :: Name -- ^ Class instance is defined for
1078                             -> Name -- ^ Class it should also be instance of
1079                             -> TcM ()
1080
1081 -- Notation: is* is for classes the type is an instance of, should* for those
1082 --           that it should also be an instance of based on the corresponding
1083 --           is*.
1084 --           Example: in case of Applicative/Monad: is = Monad,
1085 --                                                  should = Applicative
1086 tcAmpMissingParentClassWarn isName shouldName
1087   = do { isClass'     <- tcLookupClass_maybe isName
1088        ; shouldClass' <- tcLookupClass_maybe shouldName
1089        ; case (isClass', shouldClass') of
1090               (Just isClass, Just shouldClass) -> do
1091                   { localInstances <- tcGetInsts
1092                   ; let isInstance m = is_cls m == isClass
1093                         isInsts = filter isInstance localInstances
1094                   ; traceTc "tcAmpMissingParentClassWarn/isInsts" (ppr isInsts)
1095                   ; forM_ isInsts $ checkShouldInst isClass shouldClass
1096                   }
1097               _ -> return ()
1098        }
1099   where
1100     -- Checks whether the desired superclass exists in a given environment.
1101     checkShouldInst :: Class   -- ^ Class of existing instance
1102                     -> Class   -- ^ Class there should be an instance of
1103                     -> ClsInst -- ^ Existing instance
1104                     -> TcM ()
1105     checkShouldInst isClass shouldClass isInst
1106       = do { instEnv <- tcGetInstEnvs
1107            ; let (instanceMatches, shouldInsts, _)
1108                     = lookupInstEnv instEnv shouldClass (is_tys isInst)
1109
1110            ; traceTc "tcAmpMissingParentClassWarn/checkShouldInst"
1111                      (hang (ppr isInst) 4
1112                          (sep [ppr instanceMatches, ppr shouldInsts]))
1113
1114            -- "<location>: Warning: <type> is an instance of <is> but not <should>"
1115            -- e.g. "Foo is an instance of Monad but not Applicative"
1116            ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst
1117                  warnMsg (Just name:_) =
1118                       addWarnAt instLoc . hsep $
1119                            [ quotes (ppr $ nameOccName name)
1120                            , ptext (sLit "is an instance of")
1121                            , ppr . nameOccName $ className isClass
1122                            , ptext (sLit "but not")
1123                            , ppr . nameOccName $ className shouldClass
1124                            , ptext (sLit "- this will become an error in GHC 7.10,")
1125                            , ptext (sLit "under the Applicative-Monad Proposal.")
1126                            ]
1127                  warnMsg _ = return ()
1128            ; when (null shouldInsts && null instanceMatches) $
1129                   warnMsg (is_tcs isInst)
1130            }
1131
1132
1133 -- | Looks up a class, returning Nothing on failure. Similar to
1134 --   TcEnv.tcLookupClass, but does not issue any error messages.
1135 --
1136 -- In particular, it may be called by the AMP check on, say, 
1137 -- Control.Applicative.Applicative, well before Control.Applicative 
1138 -- has been compiled.  In this case we just return Nothing, and the
1139 -- AMP test is silently dropped.
1140 tcLookupClass_maybe :: Name -> TcM (Maybe Class)
1141 tcLookupClass_maybe name
1142   = do { mb_thing <- tcLookupImported_maybe name
1143        ; case mb_thing of
1144             Succeeded (ATyCon tc) | Just cls <- tyConClass_maybe tc -> return (Just cls)
1145             _ -> return Nothing }
1146 \end{code}
1147
1148
1149 %************************************************************************
1150 %*                                                                      *
1151                 tcTopSrcDecls
1152 %*                                                                      *
1153 %************************************************************************
1154
1155
1156 \begin{code}
1157 tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
1158 tcTopSrcDecls boot_details
1159         (HsGroup { hs_tyclds = tycl_decls,
1160                    hs_instds = inst_decls,
1161                    hs_derivds = deriv_decls,
1162                    hs_fords  = foreign_decls,
1163                    hs_defds  = default_decls,
1164                    hs_annds  = annotation_decls,
1165                    hs_ruleds = rule_decls,
1166                    hs_vects  = vect_decls,
1167                    hs_valds  = val_binds })
1168  = do {         -- Type-check the type and class decls, and all imported decls
1169                 -- The latter come in via tycl_decls
1170         traceTc "Tc2 (src)" empty ;
1171
1172                 -- Source-language instances, including derivings,
1173                 -- and import the supporting declarations
1174         traceTc "Tc3" empty ;
1175         (tcg_env, inst_infos, deriv_binds)
1176             <- tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls ;
1177         setGblEnv tcg_env       $ do {
1178
1179
1180                 -- Generate Applicative/Monad proposal (AMP) warnings
1181         traceTc "Tc3b" empty ;
1182         tcAmpWarn ;
1183
1184                 -- Foreign import declarations next.
1185         traceTc "Tc4" empty ;
1186         (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ;
1187         tcExtendGlobalValEnv fi_ids     $ do {
1188
1189                 -- Default declarations
1190         traceTc "Tc4a" empty ;
1191         default_tys <- tcDefaults default_decls ;
1192         updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
1193
1194                 -- Now GHC-generated derived bindings, generics, and selectors
1195                 -- Do not generate warnings from compiler-generated code;
1196                 -- hence the use of discardWarnings
1197         tc_envs <- discardWarnings (tcTopBinds deriv_binds) ;
1198         setEnvs tc_envs $ do {
1199
1200                 -- Value declarations next
1201         traceTc "Tc5" empty ;
1202         tc_envs@(tcg_env, tcl_env) <- tcTopBinds val_binds;
1203         setEnvs tc_envs $ do {  -- Environment doesn't change now
1204
1205                 -- Second pass over class and instance declarations,
1206                 -- now using the kind-checked decls
1207         traceTc "Tc6" empty ;
1208         inst_binds <- tcInstDecls2 (tyClGroupConcat tycl_decls) inst_infos ;
1209
1210                 -- Foreign exports
1211         traceTc "Tc7" empty ;
1212         (foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ;
1213
1214                 -- Annotations
1215         annotations <- tcAnnotations annotation_decls ;
1216
1217                 -- Rules
1218         rules <- tcRules rule_decls ;
1219
1220                 -- Vectorisation declarations
1221         vects <- tcVectDecls vect_decls ;
1222
1223                 -- Wrap up
1224         traceTc "Tc7a" empty ;
1225         let { all_binds = inst_binds     `unionBags`
1226                           foe_binds
1227
1228             ; fo_gres = fi_gres `unionBags` foe_gres
1229             ; fo_fvs = foldrBag (\gre fvs -> fvs `addOneFV` gre_name gre) 
1230                                 emptyFVs fo_gres
1231             ; fo_rdr_names :: [RdrName]
1232             ; fo_rdr_names = foldrBag gre_to_rdr_name [] fo_gres
1233
1234             ; sig_names = mkNameSet (collectHsValBinders val_binds)
1235                           `minusNameSet` getTypeSigNames val_binds
1236
1237                 -- Extend the GblEnv with the (as yet un-zonked)
1238                 -- bindings, rules, foreign decls
1239             ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds
1240                                  , tcg_sigs  = tcg_sigs tcg_env `unionNameSets` sig_names
1241                                  , tcg_rules = tcg_rules tcg_env ++ rules
1242                                  , tcg_vects = tcg_vects tcg_env ++ vects
1243                                  , tcg_anns  = tcg_anns tcg_env ++ annotations
1244                                  , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls
1245                                  , tcg_dus   = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ;
1246                                  -- tcg_dus: see Note [Newtype constructor usage in foreign declarations]
1247
1248         addUsedRdrNames fo_rdr_names ;
1249         return (tcg_env', tcl_env)
1250     }}}}}}
1251   where
1252     gre_to_rdr_name :: GlobalRdrElt -> [RdrName] -> [RdrName]
1253         -- For *imported* newtype data constructors, we want to
1254         -- make sure that at least one of the imports for them is used
1255         -- See Note [Newtype constructor usage in foreign declarations]
1256     gre_to_rdr_name gre rdrs
1257       = case gre_prov gre of
1258            LocalDef          -> rdrs
1259            Imported []       -> panic "gre_to_rdr_name: Imported []"
1260            Imported (is : _) -> mkRdrQual modName occName : rdrs
1261               where
1262                 modName = is_as (is_decl is)
1263                 occName = nameOccName (gre_name gre)
1264
1265 ---------------------------
1266 tcTyClsInstDecls :: ModDetails 
1267                  -> [TyClGroup Name] 
1268                  -> [LInstDecl Name]
1269                  -> [LDerivDecl Name]
1270                  -> TcM (TcGblEnv,            -- The full inst env
1271                          [InstInfo Name],     -- Source-code instance decls to process;
1272                                               -- contains all dfuns for this module
1273                           HsValBinds Name)    -- Supporting bindings for derived instances
1274
1275 tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls
1276  = tcExtendTcTyThingEnv [(con, APromotionErr FamDataConPE) 
1277                         | lid <- inst_decls, con <- get_cons lid ] $
1278       -- Note [AFamDataCon: not promoting data family constructors]
1279    do { tcg_env <- tcTyAndClassDecls boot_details tycl_decls ;
1280       ; setGblEnv tcg_env $
1281         tcInstDecls1 (tyClGroupConcat tycl_decls) inst_decls deriv_decls }
1282   where
1283     -- get_cons extracts the *constructor* bindings of the declaration
1284     get_cons :: LInstDecl Name -> [Name]
1285     get_cons (L _ (TyFamInstD {}))                     = []
1286     get_cons (L _ (DataFamInstD { dfid_inst = fid }))  = get_fi_cons fid
1287     get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))
1288       = concatMap (get_fi_cons . unLoc) fids
1289
1290     get_fi_cons :: DataFamInstDecl Name -> [Name]
1291     get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } }) 
1292       = map (unLoc . con_name . unLoc) cons
1293 \end{code}
1294
1295 Note [AFamDataCon: not promoting data family constructors]
1296 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1297 Consider
1298   data family T a
1299   data instance T Int = MkT
1300   data Proxy (a :: k)
1301   data S = MkS (Proxy 'MkT)
1302
1303 Is it ok to use the promoted data family instance constructor 'MkT' in
1304 the data declaration for S?  No, we don't allow this. It *might* make
1305 sense, but at least it would mean that we'd have to interleave
1306 typechecking instances and data types, whereas at present we do data
1307 types *then* instances.
1308
1309 So to check for this we put in the TcLclEnv a binding for all the family
1310 constructors, bound to AFamDataCon, so that if we trip over 'MkT' when
1311 type checking 'S' we'll produce a decent error message.
1312
1313
1314 %************************************************************************
1315 %*                                                                      *
1316         Checking for 'main'
1317 %*                                                                      *
1318 %************************************************************************
1319
1320 \begin{code}
1321 checkMain :: TcM TcGblEnv
1322 -- If we are in module Main, check that 'main' is defined.
1323 checkMain
1324   = do { tcg_env   <- getGblEnv ;
1325          dflags    <- getDynFlags ;
1326          check_main dflags tcg_env
1327     }
1328
1329 check_main :: DynFlags -> TcGblEnv -> TcM TcGblEnv
1330 check_main dflags tcg_env
1331  | mod /= main_mod
1332  = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >>
1333    return tcg_env
1334
1335  | otherwise
1336  = do   { mb_main <- lookupGlobalOccRn_maybe main_fn
1337                 -- Check that 'main' is in scope
1338                 -- It might be imported from another module!
1339         ; case mb_main of {
1340              Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn)
1341                            ; complain_no_main
1342                            ; return tcg_env } ;
1343              Just main_name -> do
1344
1345         { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn)
1346         ; let loc = srcLocSpan (getSrcLoc main_name)
1347         ; ioTyCon <- tcLookupTyCon ioTyConName
1348         ; res_ty <- newFlexiTyVarTy liftedTypeKind
1349         ; main_expr
1350                 <- addErrCtxt mainCtxt    $
1351                    tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty])
1352
1353                 -- See Note [Root-main Id]
1354                 -- Construct the binding
1355                 --      :Main.main :: IO res_ty = runMainIO res_ty main
1356         ; run_main_id <- tcLookupId runMainIOName
1357         ; let { root_main_name =  mkExternalName rootMainKey rOOT_MAIN
1358                                    (mkVarOccFS (fsLit "main"))
1359                                    (getSrcSpan main_name)
1360               ; root_main_id = Id.mkExportedLocalId root_main_name
1361                                                     (mkTyConApp ioTyCon [res_ty])
1362               ; co  = mkWpTyApps [res_ty]
1363               ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
1364               ; main_bind = mkVarBind root_main_id rhs }
1365
1366         ; return (tcg_env { tcg_main  = Just main_name,
1367                             tcg_binds = tcg_binds tcg_env
1368                                         `snocBag` main_bind,
1369                             tcg_dus   = tcg_dus tcg_env
1370                                         `plusDU` usesOnly (unitFV main_name)
1371                         -- Record the use of 'main', so that we don't
1372                         -- complain about it being defined but not used
1373                  })
1374     }}}
1375   where
1376     mod          = tcg_mod tcg_env
1377     main_mod     = mainModIs dflags
1378     main_fn      = getMainFun dflags
1379
1380     complain_no_main | ghcLink dflags == LinkInMemory = return ()
1381                      | otherwise = failWithTc noMainMsg
1382         -- In interactive mode, don't worry about the absence of 'main'
1383         -- In other modes, fail altogether, so that we don't go on
1384         -- and complain a second time when processing the export list.
1385
1386     mainCtxt  = ptext (sLit "When checking the type of the") <+> pp_main_fn
1387     noMainMsg = ptext (sLit "The") <+> pp_main_fn
1388                 <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod)
1389     pp_main_fn = ppMainFn main_fn
1390
1391 -- | Get the unqualified name of the function to use as the \"main\" for the main module.
1392 -- Either returns the default name or the one configured on the command line with -main-is
1393 getMainFun :: DynFlags -> RdrName
1394 getMainFun dflags = case mainFunIs dflags of
1395                       Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn))
1396                       Nothing -> main_RDR_Unqual
1397
1398 checkMainExported :: TcGblEnv -> TcM ()
1399 checkMainExported tcg_env
1400   = case tcg_main tcg_env of
1401       Nothing -> return () -- not the main module
1402       Just main_name -> 
1403          do { dflags <- getDynFlags
1404             ; let main_mod = mainModIs dflags
1405             ; checkTc (main_name `elem` concatMap availNames (tcg_exports tcg_env)) $
1406                 ptext (sLit "The") <+> ppMainFn (nameRdrName main_name) <+>
1407                 ptext (sLit "is not exported by module") <+> quotes (ppr main_mod) }
1408
1409 ppMainFn :: RdrName -> SDoc
1410 ppMainFn main_fn
1411   | rdrNameOcc main_fn == mainOcc
1412   = ptext (sLit "IO action") <+> quotes (ppr main_fn)
1413   | otherwise
1414   = ptext (sLit "main IO action") <+> quotes (ppr main_fn)
1415
1416 mainOcc :: OccName
1417 mainOcc = mkVarOccFS (fsLit "main")
1418 \end{code}
1419
1420
1421 Note [Root-main Id]
1422 ~~~~~~~~~~~~~~~~~~~
1423 The function that the RTS invokes is always :Main.main, which we call
1424 root_main_id.  (Because GHC allows the user to have a module not
1425 called Main as the main module, we can't rely on the main function
1426 being called "Main.main".  That's why root_main_id has a fixed module
1427 ":Main".)
1428
1429 This is unusual: it's a LocalId whose Name has a Module from another
1430 module.  Tiresomely, we must filter it out again in MkIface, les we
1431 get two defns for 'main' in the interface file!
1432
1433
1434 %*********************************************************
1435 %*                                                       *
1436                 GHCi stuff
1437 %*                                                       *
1438 %*********************************************************
1439
1440 \begin{code}
1441 setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
1442 setInteractiveContext hsc_env icxt thing_inside
1443   = let -- Initialise the tcg_inst_env with instances from all home modules.
1444         -- This mimics the more selective call to hptInstances in tcRnImports
1445         (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True)
1446         (ic_insts, ic_finsts) = ic_instances icxt
1447
1448         -- Note [GHCi temporary Ids]
1449         -- Ideally we would just make a type_env from ic_tythings
1450         -- and ic_sys_vars, adding in implicit things.  However, Ids
1451         -- bound interactively might have some free type variables
1452         -- (RuntimeUnk things), and if we don't register these free
1453         -- TyVars as global TyVars then the typechecker will try to
1454         -- quantify over them and fall over in zonkQuantifiedTyVar.
1455         --
1456         -- So we must add any free TyVars to the typechecker's global
1457         -- TyVar set.  This is what happens when the local environment
1458         -- is extended, so we use tcExtendGhciEnv below which extends
1459         -- the local environment with the Ids.
1460         --
1461         -- However, any Ids bound this way will shadow other Ids in
1462         -- the GlobalRdrEnv, so we have to be careful to only add Ids
1463         -- which are visible in the GlobalRdrEnv.
1464         --
1465         -- Perhaps it would be better to just extend the global TyVar
1466         -- list from the free tyvars in the Ids here?  Anyway, at least
1467         -- this hack is localised.
1468         --
1469         -- Note [delete shadowed tcg_rdr_env entries]
1470         -- We also *delete* entries from tcg_rdr_env that we have
1471         -- shadowed in the local env (see above).  This isn't strictly
1472         -- necessary, but in an out-of-scope error when GHC suggests
1473         -- names it can be confusing to see multiple identical
1474         -- entries. (#5564)
1475         --
1476         (tmp_ids, types_n_classes) = partitionWith sel_id (ic_tythings icxt)
1477           where sel_id (AnId id) = Left id
1478                 sel_id other     = Right other
1479
1480         type_env = mkTypeEnvWithImplicits
1481                        (map AnId (ic_sys_vars icxt) ++ types_n_classes)
1482
1483         visible_tmp_ids = filter visible tmp_ids
1484           where visible id = not (null (lookupGRE_Name (ic_rn_gbl_env icxt)
1485                                                        (idName id)))
1486
1487         con_fields = [ (dataConName c, dataConFieldLabels c)
1488                      | ATyCon t <- types_n_classes
1489                      , c <- tyConDataCons t ]
1490     in
1491     updGblEnv (\env -> env {
1492           tcg_rdr_env      = delListFromOccEnv (ic_rn_gbl_env icxt)
1493                                                (map getOccName visible_tmp_ids)
1494                                  -- Note [delete shadowed tcg_rdr_env entries]
1495         , tcg_type_env     = type_env
1496         , tcg_insts        = ic_insts
1497         , tcg_inst_env     = extendInstEnvList
1498                               (extendInstEnvList (tcg_inst_env env) ic_insts)
1499                               home_insts
1500         , tcg_fam_insts    = ic_finsts
1501         , tcg_fam_inst_env = extendFamInstEnvList
1502                               (extendFamInstEnvList (tcg_fam_inst_env env)
1503                                                     ic_finsts)
1504                               home_fam_insts
1505         , tcg_field_env    = RecFields (mkNameEnv con_fields)
1506                                        (mkNameSet (concatMap snd con_fields))
1507              -- setting tcg_field_env is necessary to make RecordWildCards work
1508              -- (test: ghci049)
1509         , tcg_fix_env      = ic_fix_env icxt
1510         , tcg_default      = ic_default icxt
1511         }) $
1512
1513         tcExtendGhciEnv visible_tmp_ids $ -- Note [GHCi temporary Ids]
1514           thing_inside
1515
1516 #ifdef GHCI
1517 -- | The returned [Id] is the list of new Ids bound by this statement. It can
1518 -- be used to extend the InteractiveContext via extendInteractiveContext.
1519 --
1520 -- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound
1521 -- values, coerced to ().
1522 tcRnStmt :: HscEnv -> InteractiveContext -> GhciLStmt RdrName
1523          -> IO (Messages, Maybe ([Id], LHsExpr Id, FixityEnv))
1524 tcRnStmt hsc_env ictxt rdr_stmt
1525   = initTcPrintErrors hsc_env iNTERACTIVE $
1526     setInteractiveContext hsc_env ictxt $ do {
1527
1528     -- The real work is done here
1529     ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ;
1530     zonked_expr <- zonkTopLExpr tc_expr ;
1531     zonked_ids  <- zonkTopBndrs bound_ids ;
1532
1533         -- None of the Ids should be of unboxed type, because we
1534         -- cast them all to HValues in the end!
1535     mapM_ bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
1536
1537     traceTc "tcs 1" empty ;
1538     let { global_ids = map globaliseAndTidyId zonked_ids } ;
1539         -- Note [Interactively-bound Ids in GHCi]
1540
1541 {- ---------------------------------------------
1542    At one stage I removed any shadowed bindings from the type_env;
1543    they are inaccessible but might, I suppose, cause a space leak if we leave them there.
1544    However, with Template Haskell they aren't necessarily inaccessible.  Consider this
1545    GHCi session
1546          Prelude> let f n = n * 2 :: Int
1547          Prelude> fName <- runQ [| f |]
1548          Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
1549          14
1550          Prelude> let f n = n * 3 :: Int
1551          Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
1552    In the last line we use 'fName', which resolves to the *first* 'f'
1553    in scope. If we delete it from the type env, GHCi crashes because
1554    it doesn't expect that.
1555
1556    Hence this code is commented out
1557
1558 -------------------------------------------------- -}
1559
1560     dumpOptTcRn Opt_D_dump_tc
1561         (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
1562                text "Typechecked expr" <+> ppr zonked_expr]) ;
1563
1564     return (global_ids, zonked_expr, fix_env)
1565     }
1566   where
1567     bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"),
1568                                   nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
1569 \end{code}
1570
1571 Note [Interactively-bound Ids in GHCi]
1572 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1573 The Ids bound by previous Stmts in GHCi are currently
1574         a) GlobalIds
1575         b) with an Internal Name (not External)
1576         c) and a tidied type
1577
1578  (a) They must be GlobalIds (not LocalIds) otherwise when we come to
1579      compile an expression using these ids later, the byte code
1580      generator will consider the occurrences to be free rather than
1581      global.
1582
1583  (b) They retain their Internal names because we don't have a suitable
1584      Module to name them with. We could revisit this choice.
1585
1586  (c) Their types are tidied. This is important, because :info may ask
1587      to look at them, and :info expects the things it looks up to have
1588      tidy types
1589
1590 --------------------------------------------------------------------------
1591                 Typechecking Stmts in GHCi
1592
1593 Here is the grand plan, implemented in tcUserStmt
1594
1595         What you type                   The IO [HValue] that hscStmt returns
1596         -------------                   ------------------------------------
1597         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
1598                                         bindings: [x,y,...]
1599
1600         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
1601                                         bindings: [x,y,...]
1602
1603         expr (of IO type)       ==>     expr >>= \ it -> return [coerce HVal it]
1604           [NB: result not printed]      bindings: [it]
1605
1606         expr (of non-IO type,   ==>     let it = expr in print it >> return [coerce HVal it]
1607           result showable)              bindings: [it]
1608
1609         expr (of non-IO type,
1610           result not showable)  ==>     error
1611
1612 \begin{code}
1613
1614 -- | A plan is an attempt to lift some code into the IO monad.
1615 type PlanResult = ([Id], LHsExpr Id)
1616 type Plan = TcM PlanResult
1617
1618 -- | Try the plans in order. If one fails (by raising an exn), try the next.
1619 -- If one succeeds, take it.
1620 runPlans :: [Plan] -> TcM PlanResult
1621 runPlans []     = panic "runPlans"
1622 runPlans [p]    = p
1623 runPlans (p:ps) = tryTcLIE_ (runPlans ps) p
1624
1625 -- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the
1626 -- GHCi 'environemnt'.
1627 --
1628 -- By 'lift' and 'environment we mean that the code is changed to execute
1629 -- properly in an IO monad. See Note [Interactively-bound Ids in GHCi] above
1630 -- for more details. We do this lifting by trying different ways ('plans') of
1631 -- lifting the code into the IO monad and type checking each plan until one
1632 -- succeeds.
1633 tcUserStmt :: GhciLStmt RdrName -> TcM (PlanResult, FixityEnv)
1634
1635 -- An expression typed at the prompt is treated very specially
1636 tcUserStmt (L loc (BodyStmt expr _ _ _))
1637   = do  { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr)
1638                -- Don't try to typecheck if the renamer fails!
1639         ; ghciStep <- getGhciStepIO
1640         ; uniq <- newUnique
1641         ; interPrintName <- getInteractivePrintName
1642         ; let fresh_it  = itName uniq loc
1643               matches   = [mkMatch [] rn_expr emptyLocalBinds]
1644               -- [it = expr]
1645               the_bind  = L loc $ (mkTopFunBind (L loc fresh_it) matches) { bind_fvs = fvs }
1646                           -- Care here!  In GHCi the expression might have
1647                           -- free variables, and they in turn may have free type variables
1648                           -- (if we are at a breakpoint, say).  We must put those free vars
1649
1650               -- [let it = expr]
1651               let_stmt  = L loc $ LetStmt $ HsValBinds $
1652                           ValBindsOut [(NonRecursive,unitBag the_bind)] []
1653
1654               -- [it <- e]
1655               bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it))
1656                                            (nlHsApp ghciStep rn_expr)
1657                                            (HsVar bindIOName) noSyntaxExpr
1658
1659               -- [; print it]
1660               print_it  = L loc $ BodyStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it))
1661                                            (HsVar thenIOName) noSyntaxExpr placeHolderType
1662
1663         -- The plans are:
1664         --   A. [it <- e; print it]     but not if it::()
1665         --   B. [it <- e]
1666         --   C. [let it = e; print it]
1667         --
1668         -- Ensure that type errors don't get deferred when type checking the
1669         -- naked expression. Deferring type errors here is unhelpful because the
1670         -- expression gets evaluated right away anyway. It also would potentially
1671         -- emit two redundant type-error warnings, one from each plan.
1672         ; plan <- unsetGOptM Opt_DeferTypeErrors $ runPlans [
1673                     -- Plan A
1674                     do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
1675                        ; it_ty <- zonkTcType (idType it_id)
1676                        ; when (isUnitTy $ it_ty) failM
1677                        ; return stuff },
1678
1679                         -- Plan B; a naked bind statment
1680                     tcGhciStmts [bind_stmt],
1681
1682                         -- Plan C; check that the let-binding is typeable all by itself.
1683                         -- If not, fail; if so, try to print it.
1684                         -- The two-step process avoids getting two errors: one from
1685                         -- the expression itself, and one from the 'print it' part
1686                         -- This two-step story is very clunky, alas
1687                     do { _ <- checkNoErrs (tcGhciStmts [let_stmt])
1688                                 --- checkNoErrs defeats the error recovery of let-bindings
1689                        ; tcGhciStmts [let_stmt, print_it] } ]
1690
1691         ; fix_env <- getFixityEnv
1692         ; return (plan, fix_env) }
1693
1694 tcUserStmt rdr_stmt@(L loc _)
1695   = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $
1696            rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do
1697              fix_env <- getFixityEnv
1698              return (fix_env, emptyFVs)
1699             -- Don't try to typecheck if the renamer fails!
1700        ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs])
1701        ; rnDump (ppr rn_stmt) ;
1702
1703        ; ghciStep <- getGhciStepIO
1704        ; let gi_stmt
1705                | (L loc (BindStmt pat expr op1 op2)) <- rn_stmt
1706                            = L loc $ BindStmt pat (nlHsApp ghciStep expr) op1 op2
1707                | otherwise = rn_stmt
1708
1709        ; opt_pr_flag <- goptM Opt_PrintBindResult
1710        ; let print_result_plan
1711                | opt_pr_flag                         -- The flag says "print result"   
1712                , [v] <- collectLStmtBinders gi_stmt  -- One binder
1713                            =  [mk_print_result_plan gi_stmt v]
1714                | otherwise = []
1715
1716         -- The plans are:
1717         --      [stmt; print v]         if one binder and not v::()
1718         --      [stmt]                  otherwise
1719        ; plan <- runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]])
1720        ; return (plan, fix_env) }
1721   where
1722     mk_print_result_plan stmt v
1723       = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
1724            ; v_ty <- zonkTcType (idType v_id)
1725            ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM
1726            ; return stuff }
1727       where
1728         print_v  = L loc $ BodyStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
1729                                     (HsVar thenIOName) noSyntaxExpr placeHolderType
1730
1731 -- | Typecheck the statements given and then return the results of the
1732 -- statement in the form 'IO [()]'.
1733 tcGhciStmts :: [GhciLStmt Name] -> TcM PlanResult
1734 tcGhciStmts stmts
1735  = do { ioTyCon <- tcLookupTyCon ioTyConName ;
1736         ret_id  <- tcLookupId returnIOName ;            -- return @ IO
1737         let {
1738             ret_ty      = mkListTy unitTy ;
1739             io_ret_ty   = mkTyConApp ioTyCon [ret_ty] ;
1740             tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts io_ret_ty ;
1741             names = collectLStmtsBinders stmts ;
1742          } ;
1743
1744         -- OK, we're ready to typecheck the stmts
1745         traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
1746         ((tc_stmts, ids), lie) <- captureConstraints $
1747                                   tc_io_stmts $ \ _ ->
1748                                   mapM tcLookupId names  ;
1749                         -- Look up the names right in the middle,
1750                         -- where they will all be in scope
1751
1752         -- Simplify the context
1753         traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
1754         const_binds <- checkNoErrs (simplifyInteractive lie) ;
1755                 -- checkNoErrs ensures that the plan fails if context redn fails
1756
1757         traceTc "TcRnDriver.tcGhciStmts: done" empty ;
1758         let {   -- mk_return builds the expression
1759                 --      returnIO @ [()] [coerce () x, ..,  coerce () z]
1760                 --
1761                 -- Despite the inconvenience of building the type applications etc,
1762                 -- this *has* to be done in type-annotated post-typecheck form
1763                 -- because we are going to return a list of *polymorphic* values
1764                 -- coerced to type (). If we built a *source* stmt
1765                 --      return [coerce x, ..., coerce z]
1766                 -- then the type checker would instantiate x..z, and we wouldn't
1767                 -- get their *polymorphic* values.  (And we'd get ambiguity errs
1768                 -- if they were overloaded, since they aren't applied to anything.)
1769             ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty])
1770                        (noLoc $ ExplicitList unitTy Nothing (map mk_item ids)) ;
1771             mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy])
1772                                  (nlHsVar id) ;
1773             stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]
1774         } ;
1775         return (ids, mkHsDictLet (EvBinds const_binds) $
1776                      noLoc (HsDo GhciStmtCtxt stmts io_ret_ty))
1777     }
1778
1779 -- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a)
1780 getGhciStepIO :: TcM (LHsExpr Name)
1781 getGhciStepIO = do
1782     ghciTy <- getGHCiMonad
1783     fresh_a <- newUnique
1784     let a_tv   = mkTcTyVarName fresh_a (fsLit "a")
1785         ghciM  = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)
1786         ioM    = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)
1787
1788         stepTy :: LHsType Name    -- Renamed, so needs all binders in place
1789         stepTy = noLoc $ HsForAllTy Implicit
1790                             (HsQTvs { hsq_tvs = [noLoc (UserTyVar a_tv)]
1791                                     , hsq_kvs = [] })
1792                             (noLoc [])
1793                             (nlHsFunTy ghciM ioM)
1794         step   = noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy
1795     return step
1796
1797 isGHCiMonad :: HscEnv -> InteractiveContext -> String -> IO (Messages, Maybe Name)
1798 isGHCiMonad hsc_env ictxt ty
1799   = initTcPrintErrors hsc_env iNTERACTIVE $
1800     setInteractiveContext hsc_env ictxt $ do
1801         rdrEnv <- getGlobalRdrEnv
1802         let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty)
1803         case occIO of
1804             Just [n] -> do
1805                 let name = gre_name n
1806                 ghciClass <- tcLookupClass ghciIoClassName 
1807                 userTyCon <- tcLookupTyCon name
1808                 let userTy = mkTyConApp userTyCon []
1809                 _ <- tcLookupInstance ghciClass [userTy]
1810                 return name
1811
1812             Just _  -> failWithTc $ text "Ambigous type!"
1813             Nothing -> failWithTc $ text ("Can't find type:" ++ ty)
1814
1815 \end{code}
1816
1817 tcRnExpr just finds the type of an expression
1818
1819 \begin{code}
1820 tcRnExpr :: HscEnv
1821          -> InteractiveContext
1822          -> LHsExpr RdrName
1823          -> IO (Messages, Maybe Type)
1824 -- Type checks the expression and returns its most general type
1825 tcRnExpr hsc_env ictxt rdr_expr
1826   = initTcPrintErrors hsc_env iNTERACTIVE $
1827     setInteractiveContext hsc_env ictxt $ do {
1828
1829     (rn_expr, _fvs) <- rnLExpr rdr_expr ;
1830     failIfErrsM ;
1831
1832         -- Now typecheck the expression;
1833         -- it might have a rank-2 type (e.g. :t runST)
1834     uniq <- newUnique ;
1835     let { fresh_it  = itName uniq (getLoc rdr_expr) } ;
1836     ((_tc_expr, res_ty), lie) <- captureConstraints $ 
1837                                  tcInferRho rn_expr ;
1838     ((qtvs, dicts, _, _), lie_top) <- captureConstraints $
1839                                       {-# SCC "simplifyInfer" #-}
1840                                       simplifyInfer True {- Free vars are closed -}
1841                                                     False {- No MR for now -}
1842                                                     [(fresh_it, res_ty)]
1843                                                     lie ;
1844     _ <- simplifyInteractive lie_top ;       -- Ignore the dicionary bindings
1845
1846     let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
1847     zonkTcType all_expr_ty
1848     }
1849
1850 --------------------------
1851 tcRnImportDecls :: HscEnv
1852                 -> [LImportDecl RdrName]
1853                 -> IO (Messages, Maybe GlobalRdrEnv)
1854 tcRnImportDecls hsc_env import_decls
1855  =  initTcPrintErrors hsc_env iNTERACTIVE $
1856     do { gbl_env <- tcRnImports hsc_env iNTERACTIVE import_decls
1857        ; return (tcg_rdr_env gbl_env) }
1858 \end{code}
1859
1860 tcRnType just finds the kind of a type
1861
1862 \begin{code}
1863 tcRnType :: HscEnv
1864          -> InteractiveContext
1865          -> Bool        -- Normalise the returned type
1866          -> LHsType RdrName
1867          -> IO (Messages, Maybe (Type, Kind))
1868 tcRnType hsc_env ictxt normalise rdr_type
1869   = initTcPrintErrors hsc_env iNTERACTIVE $
1870     setInteractiveContext hsc_env ictxt $ 
1871     setXOptM Opt_PolyKinds $   -- See Note [Kind-generalise in tcRnType]
1872     do { (rn_type, _fvs) <- rnLHsType GHCiCtx rdr_type
1873        ; failIfErrsM
1874
1875         -- Now kind-check the type
1876         -- It can have any rank or kind
1877        ; ty <- tcHsSigType GhciCtxt rn_type ;
1878
1879        ; ty' <- if normalise
1880                 then do { fam_envs <- tcGetFamInstEnvs
1881                         ; return (snd (normaliseType fam_envs Nominal ty)) }
1882                         -- normaliseType returns a coercion
1883                         -- which we discard, so the Role is irrelevant
1884                 else return ty ;
1885
1886        ; return (ty', typeKind ty) }
1887 \end{code}
1888
1889 Note [Kind-generalise in tcRnType]
1890 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1891 We switch on PolyKinds when kind-checking a user type, so that we will
1892 kind-generalise the type.  This gives the right default behaviour at
1893 the GHCi prompt, where if you say ":k T", and T has a polymorphic
1894 kind, you'd like to see that polymorphism. Of course.  If T isn't
1895 kind-polymorphic you won't get anything unexpected, but the apparent
1896 *loss* of polymorphism, for types that you know are polymorphic, is
1897 quite surprising.  See Trac #7688 for a discussion.
1898
1899
1900 %************************************************************************
1901 %*                                                                      *
1902                  tcRnDeclsi
1903 %*                                                                      *
1904 %************************************************************************
1905
1906 tcRnDeclsi exists to allow class, data, and other declarations in GHCi.
1907
1908 \begin{code}
1909 tcRnDeclsi :: HscEnv
1910            -> InteractiveContext
1911            -> [LHsDecl RdrName]
1912            -> IO (Messages, Maybe TcGblEnv)
1913
1914 tcRnDeclsi hsc_env ictxt local_decls =
1915     initTcPrintErrors hsc_env iNTERACTIVE $
1916     setInteractiveContext hsc_env ictxt $ do
1917
1918     ((tcg_env, tclcl_env), lie) <-
1919         captureConstraints $ tc_rn_src_decls emptyModDetails local_decls
1920     setEnvs (tcg_env, tclcl_env) $ do
1921
1922     new_ev_binds <- simplifyTop lie
1923     failIfErrsM
1924     let TcGblEnv { tcg_type_env  = type_env,
1925                    tcg_binds     = binds,
1926                    tcg_sigs      = sig_ns,
1927                    tcg_ev_binds  = cur_ev_binds,
1928                    tcg_imp_specs = imp_specs,
1929                    tcg_rules     = rules,
1930                    tcg_vects     = vects,
1931                    tcg_fords     = fords } = tcg_env
1932         all_ev_binds = cur_ev_binds `unionBags` new_ev_binds
1933
1934     (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
1935         <- zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords
1936
1937     let --global_ids = map globaliseAndTidyId bind_ids
1938         final_type_env = extendTypeEnvWithIds type_env bind_ids --global_ids
1939         tcg_env' = tcg_env { tcg_binds     = binds',
1940                              tcg_ev_binds  = ev_binds',
1941                              tcg_imp_specs = imp_specs',
1942                              tcg_rules     = rules',
1943                              tcg_vects     = vects',
1944                              tcg_fords     = fords' }
1945
1946     setGlobalTypeEnv tcg_env' final_type_env
1947     
1948 #endif /* GHCi */
1949 \end{code}
1950
1951
1952 %************************************************************************
1953 %*                                                                      *
1954         More GHCi stuff, to do with browsing and getting info
1955 %*                                                                      *
1956 %************************************************************************
1957
1958 \begin{code}
1959 #ifdef GHCI
1960 -- | ASSUMES that the module is either in the 'HomePackageTable' or is
1961 -- a package module with an interface on disk.  If neither of these is
1962 -- true, then the result will be an error indicating the interface
1963 -- could not be found.
1964 getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface)
1965 getModuleInterface hsc_env mod
1966   = initTc hsc_env HsSrcFile False iNTERACTIVE $
1967     loadModuleInterface (ptext (sLit "getModuleInterface")) mod
1968
1969 tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Messages, Maybe [Name])
1970 tcRnLookupRdrName hsc_env rdr_name
1971   = initTcPrintErrors hsc_env iNTERACTIVE $
1972     setInteractiveContext hsc_env (hsc_IC hsc_env) $
1973     lookup_rdr_name rdr_name
1974
1975 lookup_rdr_name :: RdrName -> TcM [Name]
1976 lookup_rdr_name rdr_name = do
1977         -- If the identifier is a constructor (begins with an
1978         -- upper-case letter), then we need to consider both
1979         -- constructor and type class identifiers.
1980     let rdr_names = dataTcOccs rdr_name
1981
1982         -- results :: [Either Messages Name]
1983     results <- mapM (tryTcErrs . lookupOccRn) rdr_names
1984
1985     traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)])
1986         -- The successful lookups will be (Just name)
1987     let (warns_s, good_names) = unzip [ (msgs, name)
1988                                       | (msgs, Just name) <- results]
1989         errs_s = [msgs | (msgs, Nothing) <- results]
1990
1991         -- Fail if nothing good happened, else add warnings
1992     if null good_names
1993       then  addMessages (head errs_s) >> failM
1994                 -- No lookup succeeded, so
1995                 -- pick the first error message and report it
1996                 -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
1997                 --       while the other is "X is not in scope",
1998                 --       we definitely want the former; but we might pick the latter
1999       else      mapM_ addMessages warns_s
2000                 -- Add deprecation warnings
2001     return good_names
2002
2003 #endif
2004
2005 tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)
2006 tcRnLookupName hsc_env name
2007   = initTcPrintErrors hsc_env iNTERACTIVE $
2008     setInteractiveContext hsc_env (hsc_IC hsc_env) $
2009     tcRnLookupName' name
2010
2011 -- To look up a name we have to look in the local environment (tcl_lcl)
2012 -- as well as the global environment, which is what tcLookup does.
2013 -- But we also want a TyThing, so we have to convert:
2014
2015 tcRnLookupName' :: Name -> TcRn TyThing
2016 tcRnLookupName' name = do
2017    tcthing <- tcLookup name
2018    case tcthing of
2019      AGlobal thing    -> return thing
2020      ATcId{tct_id=id} -> return (AnId id)
2021      _ -> panic "tcRnLookupName'"
2022
2023 tcRnGetInfo :: HscEnv
2024             -> Name
2025             -> IO (Messages, Maybe (TyThing, Fixity, [ClsInst], [FamInst]))
2026
2027 -- Used to implement :info in GHCi
2028 --
2029 -- Look up a RdrName and return all the TyThings it might be
2030 -- A capitalised RdrName is given to us in the DataName namespace,
2031 -- but we want to treat it as *both* a data constructor
2032 --  *and* as a type or class constructor;
2033 -- hence the call to dataTcOccs, and we return up to two results
2034 tcRnGetInfo hsc_env name
2035   = let ictxt = hsc_IC hsc_env in
2036     initTcPrintErrors hsc_env iNTERACTIVE $
2037     setInteractiveContext hsc_env ictxt  $ do
2038
2039         -- Load the interface for all unqualified types and classes
2040         -- That way we will find all the instance declarations
2041         -- (Packages have not orphan modules, and we assume that
2042         --  in the home package all relevant modules are loaded.)
2043     loadUnqualIfaces hsc_env ictxt
2044
2045     thing  <- tcRnLookupName' name
2046     fixity <- lookupFixityRn name
2047     (cls_insts, fam_insts) <- lookupInsts thing
2048     return (thing, fixity, cls_insts, fam_insts)
2049
2050 lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst])
2051 lookupInsts (ATyCon tc)
2052   | Just cls <- tyConClass_maybe tc
2053   = do  { inst_envs <- tcGetInstEnvs
2054         ; return (classInstances inst_envs cls, []) }
2055
2056   | isOpenFamilyTyCon tc || isTyConAssoc tc
2057   = do  { inst_envs <- tcGetFamInstEnvs
2058         ; return ([], familyInstances inst_envs tc) }
2059
2060   | otherwise
2061   = do  { (pkg_ie, home_ie) <- tcGetInstEnvs
2062         ; (pkg_fie, home_fie) <- tcGetFamInstEnvs
2063                 -- Load all instances for all classes that are
2064                 -- in the type environment (which are all the ones
2065                 -- we've seen in any interface file so far)
2066
2067           -- Return only the instances relevant to the given thing, i.e.
2068           -- the instances whose head contains the thing's name.
2069         ; let cls_insts =
2070                  [ ispec        -- Search all
2071                  | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
2072                  , tc_name `elemNameSet` orphNamesOfClsInst ispec ]
2073         ; let fam_insts =
2074                  [ fispec
2075                  | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie
2076                  , tc_name `elemNameSet` orphNamesOfFamInst fispec ]
2077         ; return (cls_insts, fam_insts) }
2078   where
2079     tc_name     = tyConName tc
2080
2081 lookupInsts _ = return ([],[])
2082
2083 loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM ()
2084 -- Load the interface for everything that is in scope unqualified
2085 -- This is so that we can accurately report the instances for
2086 -- something
2087 loadUnqualIfaces hsc_env ictxt
2088   = initIfaceTcRn $ do
2089     mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
2090   where
2091     this_pkg = thisPackage (hsc_dflags hsc_env)
2092
2093     unqual_mods = filter ((/= this_pkg) . modulePackageId)
2094                   [ nameModule name
2095                   | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt),
2096                     let name = gre_name gre,
2097                     not (isInternalName name),
2098                     isTcOcc (nameOccName name),  -- Types and classes only
2099                     unQualOK gre ]               -- In scope unqualified
2100     doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified")
2101 \end{code}
2102
2103 %************************************************************************
2104 %*                                                                      *
2105                 Degugging output
2106 %*                                                                      *
2107 %************************************************************************
2108
2109 \begin{code}
2110 rnDump :: SDoc -> TcRn ()
2111 -- Dump, with a banner, if -ddump-rn
2112 rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
2113
2114 tcDump :: TcGblEnv -> TcRn ()
2115 tcDump env
2116  = do { dflags <- getDynFlags ;
2117
2118         -- Dump short output if -ddump-types or -ddump-tc
2119         when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
2120              (dumpTcRn short_dump) ;
2121
2122         -- Dump bindings if -ddump-tc
2123         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
2124    }
2125   where
2126     short_dump = pprTcGblEnv env
2127     full_dump  = pprLHsBinds (tcg_binds env)
2128         -- NB: foreign x-d's have undefined's in their types;
2129         --     hence can't show the tc_fords
2130
2131 tcCoreDump :: ModGuts -> TcM ()
2132 tcCoreDump mod_guts
2133  = do { dflags <- getDynFlags ;
2134         when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
2135              (dumpTcRn (pprModGuts mod_guts)) ;
2136
2137         -- Dump bindings if -ddump-tc
2138         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
2139   where
2140     full_dump = pprCoreBindings (mg_binds mod_guts)
2141
2142 -- It's unpleasant having both pprModGuts and pprModDetails here
2143 pprTcGblEnv :: TcGblEnv -> SDoc
2144 pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env,
2145                         tcg_insts     = insts,
2146                         tcg_fam_insts = fam_insts,
2147                         tcg_rules     = rules,
2148                         tcg_vects     = vects,
2149                         tcg_imports   = imports })
2150   = vcat [ ppr_types insts type_env
2151          , ppr_tycons fam_insts type_env
2152          , ppr_insts insts
2153          , ppr_fam_insts fam_insts
2154          , vcat (map ppr rules)
2155          , vcat (map ppr vects)
2156          , ptext (sLit "Dependent modules:") <+>
2157                 ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))
2158          , ptext (sLit "Dependent packages:") <+>
2159                 ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)]
2160   where         -- The two uses of sortBy are just to reduce unnecessary
2161                 -- wobbling in testsuite output
2162     cmp_mp (mod_name1, is_boot1) (mod_name2, is_boot2)
2163         = (mod_name1 `stableModuleNameCmp` mod_name2)
2164                   `thenCmp`
2165           (is_boot1 `compare` is_boot2)
2166
2167 pprModGuts :: ModGuts -> SDoc
2168 pprModGuts (ModGuts { mg_tcs = tcs
2169                     , mg_rules = rules })
2170   = vcat [ ppr_types [] (mkTypeEnv (map ATyCon tcs)),
2171            ppr_rules rules ]
2172
2173 ppr_types :: [ClsInst] -> TypeEnv -> SDoc
2174 ppr_types insts type_env
2175   = text "TYPE SIGNATURES" $$ nest 2 (ppr_sigs ids)
2176   where
2177     dfun_ids = map instanceDFunId insts
2178     ids = [id | id <- typeEnvIds type_env, want_sig id]
2179     want_sig id | opt_PprStyle_Debug = True
2180                 | otherwise          = isLocalId id &&
2181                                        isExternalName (idName id) &&
2182                                        not (id `elem` dfun_ids)
2183         -- isLocalId ignores data constructors, records selectors etc.
2184         -- The isExternalName ignores local dictionary and method bindings
2185         -- that the type checker has invented.  Top-level user-defined things
2186         -- have External names.
2187
2188 ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
2189 ppr_tycons fam_insts type_env
2190   = vcat [ text "TYPE CONSTRUCTORS"
2191          ,   nest 2 (ppr_tydecls tycons)
2192          , text "COERCION AXIOMS"
2193          ,   nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ]
2194   where
2195     fi_tycons = famInstsRepTyCons fam_insts
2196     tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon]
2197     want_tycon tycon | opt_PprStyle_Debug = True
2198                      | otherwise          = not (isImplicitTyCon tycon) &&
2199                                             isExternalName (tyConName tycon) &&
2200                                             not (tycon `elem` fi_tycons)
2201
2202 ppr_insts :: [ClsInst] -> SDoc
2203 ppr_insts []     = empty
2204 ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
2205
2206 ppr_fam_insts :: [FamInst] -> SDoc
2207 ppr_fam_insts []        = empty
2208 ppr_fam_insts fam_insts =
2209   text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts)
2210
2211 ppr_sigs :: [Var] -> SDoc
2212 ppr_sigs ids
2213         -- Print type signatures; sort by OccName
2214   = vcat (map ppr_sig (sortBy (comparing getOccName) ids))
2215   where
2216     ppr_sig id = hang (ppr id <+> dcolon) 2 (ppr (tidyTopType (idType id)))
2217
2218 ppr_tydecls :: [TyCon] -> SDoc
2219 ppr_tydecls tycons
2220         -- Print type constructor info; sort by OccName
2221   = vcat (map ppr_tycon (sortBy (comparing getOccName) tycons))
2222   where
2223     ppr_tycon tycon = vcat [ ppr (tyConName tycon) <+> dcolon <+> ppr (tyConKind tycon)
2224                               -- Temporarily print the kind signature too
2225                            , ppr (tyThingToIfaceDecl (ATyCon tycon)) ]
2226
2227 ppr_rules :: [CoreRule] -> SDoc
2228 ppr_rules [] = empty
2229 ppr_rules rs = vcat [ptext (sLit "{-# RULES"),
2230                       nest 2 (pprRules rs),
2231                       ptext (sLit "#-}")]
2232 \end{code}