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