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