TcRnDriver.lhs 79.5 KB
Newer Older
1
%
2
% (c) The University of Glasgow 2006
3
4
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
5
\section[TcMovectle]{Typechecking a whole module}
6
7
8
9

\begin{code}
module TcRnDriver (
#ifdef GHCI
dterei's avatar
dterei committed
10
11
12
13
14
        tcRnStmt, tcRnExpr, tcRnType,
        tcRnImportDecls,
        tcRnLookupRdrName,
        getModuleInterface,
        tcRnDeclsi,
dterei's avatar
dterei committed
15
        isGHCiMonad,
16
#endif
dterei's avatar
dterei committed
17
18
        tcRnLookupName,
        tcRnGetInfo,
dterei's avatar
dterei committed
19
        tcRnModule,
dterei's avatar
dterei committed
20
21
        tcTopSrcDecls,
        tcRnExtCore
22
23
    ) where

24
#ifdef GHCI
chak's avatar
chak committed
25
import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
26
27
#endif

28
29
30
31
32
33
34
import DynFlags
import StaticFlags
import HsSyn
import PrelNames
import RdrName
import TcHsSyn
import TcExpr
35
import TcRnMonad
36
37
import TcEvidence
import Coercion( pprCoAxiom )
38
import FamInst
39
40
import InstEnv
import FamInstEnv
41
import TcAnnotations
42
import TcBinds
43
import HeaderInfo       ( mkPrelImports )
44
45
46
47
48
49
import TcDefaults
import TcEnv
import TcRules
import TcForeign
import TcInstDcls
import TcIface
50
import TcMType
51
import MkIface
52
import IfaceSyn
53
54
55
56
57
58
59
60
61
62
import TcSimplify
import TcTyClsDecls
import LoadIface
import RnNames
import RnEnv
import RnSource
import PprCore
import CoreSyn
import ErrUtils
import Id
63
import VarEnv
Simon Marlow's avatar
Simon Marlow committed
64
import Module
65
import UniqFM
66
import Name
67
import NameEnv
68
import NameSet
69
import Avail
70
71
72
import TyCon
import SrcLoc
import HscTypes
73
import ListSetOps
74
import Outputable
75
76
77
import DataCon
import Type
import Class
78
import CoAxiom  ( CoAxBranch(..) )
dterei's avatar
dterei committed
79
import Inst     ( tcGetInstEnvs )
80
import Data.List ( sortBy )
GregWeber's avatar
GregWeber committed
81
import Data.IORef ( readIORef )
82
import Data.Ord
83

84
#ifdef GHCI
85
import TcType   ( isUnitTy, isTauTy )
86
87
88
89
90
91
import TcHsType
import TcMatches
import RnTypes
import RnExpr
import MkId
import BasicTypes
dterei's avatar
dterei committed
92
import TidyPgm    ( globaliseAndTidyId )
93
import TysWiredIn ( unitTy, mkListTy )
94
95
#endif

96
import FastString
97
import Maybes
98
99
import Util
import Bag
100

101
import Control.Monad
102

103
#include "HsVersions.h"
104
105
106
\end{code}

%************************************************************************
dterei's avatar
dterei committed
107
108
109
%*                                                                      *
        Typecheck and rename a module
%*                                                                      *
110
111
112
113
%************************************************************************


\begin{code}
114
-- | Top level entry point for typechecker and renamer
dterei's avatar
dterei committed
115
tcRnModule :: HscEnv
dterei's avatar
dterei committed
116
117
           -> HscSource
           -> Bool              -- True <=> save renamed syntax
118
           -> HsParsedModule
dterei's avatar
dterei committed
119
           -> IO (Messages, Maybe TcGblEnv)
120

121
tcRnModule hsc_env hsc_src save_rn_syntax
122
123
124
   HsParsedModule {
      hpm_module =
         (L loc (HsModule maybe_mod export_ies
dterei's avatar
dterei committed
125
                          import_decls local_decls mod_deprec
126
127
128
129
                          maybe_doc_hdr)),
      hpm_src_files =
         src_files
   }
130
131
 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;

Simon Marlow's avatar
Simon Marlow committed
132
   let { this_pkg = thisPackage (hsc_dflags hsc_env) ;
dterei's avatar
dterei committed
133
         (this_mod, prel_imp_loc)
134
            = case maybe_mod of
dterei's avatar
dterei committed
135
136
137
                Nothing -- 'module M where' is omitted
                    ->  (mAIN, srcLocSpan (srcSpanStart loc))

dterei's avatar
dterei committed
138
                Just (L mod_loc mod)  -- The normal case
139
                    -> (mkModule this_pkg mod, mod_loc) } ;
dterei's avatar
dterei committed
140
141

   initTc hsc_env hsc_src save_rn_syntax this_mod $
142
   setSrcSpan loc $
dterei's avatar
dterei committed
143
   do {         -- Deal with imports; first add implicit prelude
144
145
146
147
        implicit_prelude <- xoptM Opt_ImplicitPrelude;
        let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc
                                         implicit_prelude import_decls } ;

ian@well-typed.com's avatar
ian@well-typed.com committed
148
        whenWOptM Opt_WarnImplicitPrelude $
149
150
             when (notNull prel_imports) $ addWarn (implicitPreludeWarn) ;

dterei's avatar
dterei committed
151
        tcg_env <- {-# SCC "tcRnImports" #-}
152
                   tcRnImports hsc_env this_mod (prel_imports ++ import_decls) ;
153
154
155
156
157
158
159
160
161
162

          -- If the whole module is warned about or deprecated 
          -- (via mod_deprec) record that in tcg_warns. If we do thereby add
          -- a WarnAll, it will override any subseqent depracations added to tcg_warns
        let { tcg_env1 = case mod_deprec of 
                         Just txt -> tcg_env { tcg_warns = WarnAll txt } 
                         Nothing  -> tcg_env 
            } ;
 
        setGblEnv tcg_env1 $ do {
dterei's avatar
dterei committed
163
164
165

                -- Load the hi-boot interface for this module, if any
                -- We do this now so that the boot_names can be passed
dterei's avatar
dterei committed
166
                -- to tcTyAndClassDecls, because the boot_names are
dterei's avatar
dterei committed
167
168
169
170
171
172
173
174
175
176
177
                -- automatically considered to be loop breakers
                --
                -- Do this *after* tcRnImports, so that we know whether
                -- a module that we import imports us; and hence whether to
                -- look for a hi-boot file
        boot_iface <- tcHiBootIface hsc_src this_mod ;

                -- Rename and type check the declarations
        traceRn (text "rn1a") ;
        tcg_env <- if isHsBoot hsc_src then
                        tcRnHsBootDecls local_decls
dterei's avatar
dterei committed
178
                   else
dterei's avatar
dterei committed
179
                        {-# SCC "tcRnSrcDecls" #-}
180
                        tcRnSrcDecls boot_iface local_decls ;
dterei's avatar
dterei committed
181
182
183
        setGblEnv tcg_env               $ do {

                -- Process the export list
184
        traceRn (text "rn4a: before exports");
dterei's avatar
dterei committed
185
186
        tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ;
        traceRn (text "rn4b: after exports") ;
187

188
189
190
                -- Check that main is exported (must be after rnExports)
        checkMainExported tcg_env ;

dterei's avatar
dterei committed
191
192
193
        -- Compare the hi-boot iface (if any) with the real thing
        -- Must be done after processing the exports
        tcg_env <- checkHiBootIface tcg_env boot_iface ;
194

dterei's avatar
dterei committed
195
        -- The new type env is already available to stuff slurped from
dterei's avatar
dterei committed
196
        -- interface files, via TcEnv.updateGlobalTypeEnv
dterei's avatar
dterei committed
197
198
        -- It's important that this includes the stuff in checkHiBootIface,
        -- because the latter might add new bindings for boot_dfuns,
dterei's avatar
dterei committed
199
        -- which may be mentioned in imported unfoldings
200

dterei's avatar
dterei committed
201
202
203
                -- Don't need to rename the Haddock documentation,
                -- it's not parsed by GHC anymore.
        tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ;
204

dterei's avatar
dterei committed
205
206
                -- Report unused names
        reportUnusedNames export_ies tcg_env ;
207

208
209
210
211
                -- add extra source files to tcg_dependent_files
        addDependentFiles src_files ;

                -- Dump output and return
dterei's avatar
dterei committed
212
213
        tcDump tcg_env ;
        return tcg_env
Simon Marlow's avatar
Simon Marlow committed
214
    }}}}
215
216
217
218
219


implicitPreludeWarn :: SDoc
implicitPreludeWarn
  = ptext (sLit "Module `Prelude' implicitly imported")
220
221
222
\end{code}


223
%************************************************************************
dterei's avatar
dterei committed
224
225
226
%*                                                                      *
                Import declarations
%*                                                                      *
227
228
229
%************************************************************************

\begin{code}
dterei's avatar
dterei committed
230
tcRnImports :: HscEnv -> Module
231
            -> [LImportDecl RdrName] -> TcM TcGblEnv
232
tcRnImports hsc_env this_mod import_decls
dterei's avatar
dterei committed
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
  = do  { (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ;

        ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
                -- Make sure we record the dependencies from the DynFlags in the EPS or we
                -- end up hitting the sanity check in LoadIface.loadInterface that
                -- checks for unknown home-package modules being loaded. We put
                -- these dependencies on the left so their (non-source) imports
                -- take precedence over the (possibly-source) imports on the right.
                -- We don't add them to any other field (e.g. the imp_dep_mods of
                -- imports) because we don't want to load their instances etc.
              ; dep_mods = listToUFM [(mod_nm, (mod_nm, False)) | mod_nm <- dynFlagDependencies (hsc_dflags hsc_env)]
                                `plusUFM` imp_dep_mods imports

                -- We want instance declarations from all home-package
                -- modules below this one, including boot modules, except
                -- ourselves.  The 'except ourselves' is so that we don't
                -- get the instances from this module's hs-boot file
              ; want_instances :: ModuleName -> Bool
              ; want_instances mod = mod `elemUFM` dep_mods
                                   && mod /= moduleName this_mod
dterei's avatar
dterei committed
253
              ; (home_insts, home_fam_insts) = hptInstances hsc_env
254
                                                            want_instances
dterei's avatar
dterei committed
255
              } ;
256

dterei's avatar
dterei committed
257
                -- Record boot-file info in the EPS, so that it's
dterei's avatar
dterei committed
258
259
260
                -- visible to loadHiBootInterface in tcRnSrcDecls,
                -- and any other incrementally-performed imports
        ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
261

dterei's avatar
dterei committed
262
                -- Update the gbl env
dterei's avatar
dterei committed
263
264
        ; updGblEnv ( \ gbl ->
            gbl {
265
              tcg_rdr_env      = plusOccEnv (tcg_rdr_env gbl) rdr_env,
dterei's avatar
dterei committed
266
              tcg_imports      = tcg_imports gbl `plusImportAvails` imports,
267
              tcg_rn_imports   = rn_imports,
dterei's avatar
dterei committed
268
              tcg_inst_env     = extendInstEnvList (tcg_inst_env gbl) home_insts,
dterei's avatar
dterei committed
269
              tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
270
                                                      home_fam_insts,
dterei's avatar
dterei committed
271
272
273
274
275
              tcg_hpc          = hpc_info
            }) $ do {

        ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports))
                -- Fail if there are any errors so far
dterei's avatar
dterei committed
276
                -- The error printing (if needed) takes advantage
dterei's avatar
dterei committed
277
278
279
280
281
282
283
                -- of the tcg_env we have now set
--      ; traceIf (text "rdr_env: " <+> ppr rdr_env)
        ; failIfErrsM

                -- Load any orphan-module and family instance-module
                -- interfaces, so that their rules and instance decls will be
                -- found.
dterei's avatar
dterei committed
284
        ; loadModuleInterfaces (ptext (sLit "Loading orphan modules"))
285
                               (imp_orphs imports)
286

Simon Marlow's avatar
Simon Marlow committed
287
                -- Check type-family consistency
dterei's avatar
dterei committed
288
289
        ; traceRn (text "rn1: checking family instance consistency")
        ; let { dir_imp_mods = moduleEnvKeys
dterei's avatar
dterei committed
290
                             . imp_mods
dterei's avatar
dterei committed
291
292
                             $ imports }
        ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ;
293

dterei's avatar
dterei committed
294
        ; getGblEnv } }
295
296
297
\end{code}


298
%************************************************************************
dterei's avatar
dterei committed
299
300
301
%*                                                                      *
        Type-checking external-core modules
%*                                                                      *
302
303
304
%************************************************************************

\begin{code}
dterei's avatar
dterei committed
305
tcRnExtCore :: HscEnv
dterei's avatar
dterei committed
306
307
            -> HsExtCore RdrName
            -> IO (Messages, Maybe ModGuts)
dterei's avatar
dterei committed
308
        -- Nothing => some error occurred
309

310
tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
dterei's avatar
dterei committed
311
        -- The decls are IfaceDecls; all names are original names
312
 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
313

314
   initTc hsc_env ExtCoreFile False this_mod $ do {
315

316
   let { ldecls  = map noLoc decls } ;
317

318
       -- Bring the type and class decls into scope
319
320
       -- ToDo: check that this doesn't need to extract the val binds.
       --       It seems that only the type and class decls need to be in scope below because
dterei's avatar
dterei committed
321
       --          (a) tcTyAndClassDecls doesn't need the val binds, and
322
323
324
       --          (b) tcExtCoreBindings doesn't need anything
       --              (in fact, it might not even need to be in the scope of
       --               this tcg_env at all)
dterei's avatar
dterei committed
325
   (tc_envs, _bndrs) <- getLocalNonValBinders emptyFsEnv {- no fixity decls -}
326
                                              (mkFakeGroup ldecls) ;
327
   setEnvs tc_envs $ do {
328

329
330
331
   (rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls [] [ldecls] ;
   -- The empty list is for extra dependencies coming from .hs-boot files
   -- See Note [Extra dependencies from .hs-boot files] in RnSource
332

dterei's avatar
dterei committed
333
        -- Dump trace of renaming part
334
   rnDump (ppr rn_decls) ;
335

dterei's avatar
dterei committed
336
337
        -- Typecheck them all together so that
        -- any mutually recursive types are done right
dterei's avatar
dterei committed
338
        -- Just discard the auxiliary bindings; they are generated
dterei's avatar
dterei committed
339
        -- only for Haskell source code, and should already be in Core
340
   tcg_env   <- tcTyAndClassDecls emptyModDetails rn_decls ;
341
   safe_mode <- liftIO $ finalSafeMode (hsc_dflags hsc_env) tcg_env ;
GregWeber's avatar
GregWeber committed
342
   dep_files <- liftIO $ readIORef (tcg_dependent_files tcg_env) ;
343

344
   setGblEnv tcg_env $ do {
dterei's avatar
dterei committed
345
        -- Make the new type env available to stuff slurped from interface files
dterei's avatar
dterei committed
346

dterei's avatar
dterei committed
347
        -- Now the core bindings
348
   core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
349

GregWeber's avatar
GregWeber committed
350

dterei's avatar
dterei committed
351
        -- Wrap up
352
   let {
dterei's avatar
dterei committed
353
354
355
        bndrs      = bindersOfBinds core_binds ;
        my_exports = map (Avail . idName) bndrs ;
                -- ToDo: export the data types also?
356

357
        mod_guts = ModGuts {    mg_module    = this_mod,
dterei's avatar
dterei committed
358
                                mg_boot      = False,
359
                                mg_used_names = emptyNameSet, -- ToDo: compute usage
360
361
                                mg_used_th   = False,
                                mg_dir_imps  = emptyModuleEnv, -- ??
dterei's avatar
dterei committed
362
                                mg_deps      = noDependencies,  -- ??
363
364
365
366
367
368
                                mg_exports   = my_exports,
                                mg_tcs       = tcg_tcs tcg_env,
                                mg_insts     = tcg_insts tcg_env,
                                mg_fam_insts = tcg_fam_insts tcg_env,
                                mg_inst_env  = tcg_inst_env tcg_env,
                                mg_fam_inst_env = tcg_fam_inst_env tcg_env,
369
370
371
372
                                mg_rules        = [],
                                mg_vect_decls   = [],
                                mg_anns         = [],
                                mg_binds        = core_binds,
373
374

                                -- Stubs
375
376
377
378
379
380
381
382
383
                                mg_rdr_env      = emptyGlobalRdrEnv,
                                mg_fix_env      = emptyFixityEnv,
                                mg_warns        = NoWarnings,
                                mg_foreign      = NoStubs,
                                mg_hpc_info     = emptyHpcInfo False,
                                mg_modBreaks    = emptyModBreaks,
                                mg_vect_info    = noVectInfo,
                                mg_safe_haskell = safe_mode,
                                mg_trust_pkg    = False,
GregWeber's avatar
GregWeber committed
384
                                mg_dependent_files = dep_files
385
                            } } ;
386

387
   tcCoreDump mod_guts ;
388

389
390
   return mod_guts
   }}}}
391

392
mkFakeGroup :: [LTyClDecl a] -> HsGroup a
393
mkFakeGroup decls -- Rather clumsy; lots of unused fields
394
  = emptyRdrGroup { hs_tyclds = [decls] }
395
\end{code}
396
397


398
%************************************************************************
dterei's avatar
dterei committed
399
400
401
%*                                                                      *
        Type-checking the top level of a module
%*                                                                      *
402
%************************************************************************
403

404
\begin{code}
405
tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv
dterei's avatar
dterei committed
406
407
        -- Returns the variables free in the decls
        -- Reason: solely to report unused imports and bindings
408
tcRnSrcDecls boot_iface decls
dterei's avatar
dterei committed
409
410
 = do {         -- Do all the declarations
        ((tcg_env, tcl_env), lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ;
411
      ; traceTc "Tc8" empty ;
dterei's avatar
dterei committed
412
413
      ; setEnvs (tcg_env, tcl_env) $
   do {
414

dterei's avatar
dterei committed
415
             --         Finish simplifying class constraints
dterei's avatar
dterei committed
416
417
             --
             -- simplifyTop deals with constant or ambiguous InstIds.
dterei's avatar
dterei committed
418
419
420
421
             -- How could there be ambiguous ones?  They can only arise if a
             -- top-level decl falls under the monomorphism restriction
             -- and no subsequent decl instantiates its type.
             --
dterei's avatar
dterei committed
422
             -- We do this after checkMain, so that we use the type info
dterei's avatar
dterei committed
423
             -- that checkMain adds
dterei's avatar
dterei committed
424
             --
dterei's avatar
dterei committed
425
426
             -- We do it with both global and local env in scope:
             --  * the global env exposes the instances to simplifyTop
dterei's avatar
dterei committed
427
             --  * the local env exposes the local Ids to simplifyTop,
dterei's avatar
dterei committed
428
429
             --    so that we get better error messages (monomorphism restriction)
        new_ev_binds <- {-# SCC "simplifyTop" #-}
430
                        simplifyTop lie ;
431
        traceTc "Tc9" empty ;
432

dterei's avatar
dterei committed
433
434
435
        failIfErrsM ;   -- Don't zonk if there have been errors
                        -- It's a waste of time; and we may get debug warnings
                        -- about strangely-typed TyCons!
436

437
438
        -- Zonk the final code.  This must be done last.
        -- Even simplifyTop may do some unification.
439
        -- This pass also warns about missing type signatures
440
        let { TcGblEnv { tcg_type_env  = type_env,
441
442
443
444
445
446
447
                         tcg_binds     = binds,
                         tcg_sigs      = sig_ns,
                         tcg_ev_binds  = cur_ev_binds,
                         tcg_imp_specs = imp_specs,
                         tcg_rules     = rules,
                         tcg_vects     = vects,
                         tcg_fords     = fords } = tcg_env
448
            ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
449

dterei's avatar
dterei committed
450
        (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
451
452
            <- {-# SCC "zonkTopDecls" #-}
               zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords ;
dterei's avatar
dterei committed
453

454
455
456
457
        let { final_type_env = extendTypeEnvWithIds type_env bind_ids
            ; tcg_env' = tcg_env { tcg_binds    = binds',
                                   tcg_ev_binds = ev_binds',
                                   tcg_imp_specs = imp_specs',
dterei's avatar
dterei committed
458
459
                                   tcg_rules    = rules',
                                   tcg_vects    = vects',
460
461
                                   tcg_fords    = fords' } } ;

462
        setGlobalTypeEnv tcg_env' final_type_env
463
   } }
464

dterei's avatar
dterei committed
465
466
tc_rn_src_decls :: ModDetails
                    -> [LHsDecl RdrName]
467
                    -> TcM (TcGblEnv, TcLclEnv)
dterei's avatar
dterei committed
468
-- Loops around dealing with each top level inter-splice group
469
-- in turn, until it's dealt with the entire module
470
tc_rn_src_decls boot_details ds
471
472
 = {-# SCC "tc_rn_src_decls" #-}
   do { (first_group, group_tail) <- findSplice ds  ;
dterei's avatar
dterei committed
473
                -- If ds is [] we get ([], Nothing)
dterei's avatar
dterei committed
474
475

        -- The extra_deps are needed while renaming type and class declarations
476
        -- See Note [Extra dependencies from .hs-boot files] in RnSource
dterei's avatar
dterei committed
477
478
479
480
        let { extra_deps = map tyConName (typeEnvTyCons (md_types boot_details)) } ;
        -- Deal with decls up to, but not including, the first splice
        (tcg_env, rn_decls) <- rnTopSrcDecls extra_deps first_group ;
                -- rnTopSrcDecls fails if there are any errors
dterei's avatar
dterei committed
481
482

        (tcg_env, tcl_env) <- setGblEnv tcg_env $
dterei's avatar
dterei committed
483
                              tcTopSrcDecls boot_details rn_decls ;
484

dterei's avatar
dterei committed
485
        -- If there is no splice, we're nearly done
dterei's avatar
dterei committed
486
        setEnvs (tcg_env, tcl_env) $
dterei's avatar
dterei committed
487
488
        case group_tail of {
           Nothing -> do { tcg_env <- checkMain ;       -- Check for `main'
489
490
                           traceTc "returning from tc_rn_src_decls: " $
                             ppr $ nameEnvElts $ tcg_type_env tcg_env ; -- RAE
dterei's avatar
dterei committed
491
                           return (tcg_env, tcl_env)
dterei's avatar
dterei committed
492
                      } ;
493
494

#ifndef GHCI
dterei's avatar
dterei committed
495
496
497
        -- There shouldn't be a splice
           Just (SpliceDecl {}, _) -> do {
        failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
498
#else
dterei's avatar
dterei committed
499
500
        -- If there's a splice, we must carry on
           Just (SpliceDecl splice_expr _, rest_ds) -> do {
501

dterei's avatar
dterei committed
502
503
504
505
        -- Rename the splice expression, and get its supporting decls
        (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ;
                -- checkNoErrs: don't typecheck if renaming failed
        rnDump (ppr rn_splice_expr) ;
506

dterei's avatar
dterei committed
507
508
        -- Execute the splice
        spliced_decls <- tcSpliceDecls rn_splice_expr ;
509

dterei's avatar
dterei committed
510
511
512
        -- Glue them on the front of the remaining decls and loop
        setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
        tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
513
#endif /* GHCI */
514
    } } }
515
516
\end{code}

517
%************************************************************************
dterei's avatar
dterei committed
518
519
520
521
%*                                                                      *
        Compiling hs-boot source files, and
        comparing the hi-boot interface with the real thing
%*                                                                      *
522
523
%************************************************************************

524
525
526
\begin{code}
tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
tcRnHsBootDecls decls
527
   = do { (first_group, group_tail) <- findSplice decls
528

dterei's avatar
dterei committed
529
                -- Rename the declarations
dterei's avatar
dterei committed
530
531
        ; (tcg_env, HsGroup {
                   hs_tyclds = tycl_decls,
dterei's avatar
dterei committed
532
533
534
                   hs_instds = inst_decls,
                   hs_derivds = deriv_decls,
                   hs_fords  = for_decls,
dterei's avatar
dterei committed
535
536
537
                   hs_defds  = def_decls,
                   hs_ruleds = rule_decls,
                   hs_vects  = vect_decls,
dterei's avatar
dterei committed
538
539
                   hs_annds  = _,
                   hs_valds  = val_binds }) <- rnTopSrcDecls [] first_group
540
541
        -- The empty list is for extra dependencies coming from .hs-boot files
        -- See Note [Extra dependencies from .hs-boot files] in RnSource
dterei's avatar
dterei committed
542
543
544
545
546
547
548
549
550
551
552
553
        ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {


                -- Check for illegal declarations
        ; case group_tail of
             Just (SpliceDecl d _, _) -> badBootDecl "splice" d
             Nothing                  -> return ()
        ; mapM_ (badBootDecl "foreign") for_decls
        ; mapM_ (badBootDecl "default") def_decls
        ; mapM_ (badBootDecl "rule")    rule_decls
        ; mapM_ (badBootDecl "vect")    vect_decls

554
                -- Typecheck type/class/isntance decls
555
        ; traceTc "Tc2 (boot)" empty
dterei's avatar
dterei committed
556
        ; (tcg_env, inst_infos, _deriv_binds)
557
             <- tcTyClsInstDecls emptyModDetails tycl_decls inst_decls deriv_decls
dterei's avatar
dterei committed
558
559
560
        ; setGblEnv tcg_env     $ do {

                -- Typecheck value declarations
dterei's avatar
dterei committed
561
        ; traceTc "Tc5" empty
dterei's avatar
dterei committed
562
563
564
565
566
        ; val_ids <- tcHsBootSigs val_binds

                -- Wrap up
                -- No simplification or zonking to do
        ; traceTc "Tc7a" empty
dterei's avatar
dterei committed
567
568
        ; gbl_env <- getGblEnv

dterei's avatar
dterei committed
569
570
                -- Make the final type-env
                -- Include the dfun_ids so that their type sigs
dterei's avatar
dterei committed
571
                -- are written into the interface file.
dterei's avatar
dterei committed
572
573
        ; let { type_env0 = tcg_type_env gbl_env
              ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
dterei's avatar
dterei committed
574
              ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids
dterei's avatar
dterei committed
575
576
577
578
              ; dfun_ids = map iDFunId inst_infos
              }

        ; setGlobalTypeEnv gbl_env type_env2
579
   }}
580
   ; traceTc "boot" (ppr lie); return gbl_env }
581

582
badBootDecl :: String -> Located decl -> TcM ()
dterei's avatar
dterei committed
583
584
badBootDecl what (L loc _)
  = addErrAt loc (char 'A' <+> text what
585
      <+> ptext (sLit "declaration is not (currently) allowed in a hs-boot file"))
586
587
\end{code}

588
589
Once we've typechecked the body of the module, we want to compare what
we've found (gathered in a TypeEnv) with the hi-boot details (if any).
590
591

\begin{code}
592
checkHiBootIface :: TcGblEnv -> ModDetails -> TcM TcGblEnv
593
594
-- Compare the hi-boot file for this module (if there is one)
-- with the type environment we've just come up with
595
596
-- In the common case where there is no hi-boot file, the list
-- of boot_names is empty.
597
598
--
-- The bindings we return give bindings for the dfuns defined in the
dterei's avatar
dterei committed
599
-- hs-boot file, such as        $fbEqT = $fEqT
600

601
checkHiBootIface
dterei's avatar
dterei committed
602
        tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds,
dterei's avatar
dterei committed
603
                            tcg_insts = local_insts,
dterei's avatar
dterei committed
604
605
606
607
                            tcg_type_env = local_type_env, tcg_exports = local_exports })
        (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
                      md_types = boot_type_env, md_exports = boot_exports })
  | isHsBoot hs_src     -- Current module is already a hs-boot file!
dterei's avatar
dterei committed
608
  = return tcg_env
609
610

  | otherwise
dterei's avatar
dterei committed
611
  = do  { traceTc "checkHiBootIface" $ vcat
612
             [ ppr boot_type_env, ppr boot_insts, ppr boot_exports]
613

dterei's avatar
dterei committed
614
615
                -- Check the exports of the boot module, one by one
        ; mapM_ check_export boot_exports
616

dterei's avatar
dterei committed
617
618
619
620
                -- Check for no family instances
        ; unless (null boot_fam_insts) $
            panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
                   "instances in boot files yet...")
621
            -- FIXME: Why?  The actual comparison is not hard, but what would
dterei's avatar
dterei committed
622
623
            --        be the equivalent to the dfun bindings returned for class
            --        instances?  We can't easily equate tycons...
624

dterei's avatar
dterei committed
625
626
                -- Check instance declarations
        ; mb_dfun_prs <- mapM check_inst boot_insts
627
628
629
630
631
632
        ; let dfun_prs   = catMaybes mb_dfun_prs
              boot_dfuns = map fst dfun_prs
              dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
                                     | (boot_dfun, dfun) <- dfun_prs ]
              type_env'  = extendTypeEnvWithIds local_type_env boot_dfuns
              tcg_env'   = tcg_env { tcg_binds = binds `unionBags` dfun_binds }
633

634
        ; failIfErrsM
dterei's avatar
dterei committed
635
636
        ; setGlobalTypeEnv tcg_env' type_env' }
             -- Update the global type env *including* the knot-tied one
637
638
639
             -- so that if the source module reads in an interface unfolding
             -- mentioning one of the dfuns from the boot module, then it
             -- can "see" that boot dfun.   See Trac #4003
640
  where
dterei's avatar
dterei committed
641
    check_export boot_avail     -- boot_avail is exported by the boot iface
dterei's avatar
dterei committed
642
      | name `elem` dfun_names = return ()
dterei's avatar
dterei committed
643
644
645
      | isWiredInName name     = return ()      -- No checking for wired-in names.  In particular,
                                                -- 'error' is handled by a rather gross hack
                                                -- (see comments in GHC.Err.hs-boot)
646

dterei's avatar
dterei committed
647
        -- Check that the actual module exports the same thing
648
      | not (null missing_names)
dterei's avatar
dterei committed
649
      = addErrAt (nameSrcSpan (head missing_names))
650
                 (missingBootThing (head missing_names) "exported by")
651

dterei's avatar
dterei committed
652
653
        -- If the boot module does not *define* the thing, we are done
        -- (it simply re-exports it, and names match, so nothing further to do)
654
      | isNothing mb_boot_thing = return ()
655

dterei's avatar
dterei committed
656
        -- Check that the actual module also defines the thing, and
dterei's avatar
dterei committed
657
        -- then compare the definitions
658
659
660
661
      | Just real_thing <- lookupTypeEnv local_type_env name,
        Just boot_thing <- mb_boot_thing
      = when (not (checkBootDecl boot_thing real_thing))
            $ addErrAt (nameSrcSpan (getName boot_thing))
dterei's avatar
dterei committed
662
                       (let boot_decl = tyThingToIfaceDecl
663
664
665
                                               (fromJust mb_boot_thing)
                            real_decl = tyThingToIfaceDecl real_thing
                        in bootMisMatch real_thing boot_decl real_decl)
666

667
      | otherwise
668
      = addErrTc (missingBootThing name "defined in")
669
      where
dterei's avatar
dterei committed
670
671
672
673
674
        name          = availName boot_avail
        mb_boot_thing = lookupTypeEnv boot_type_env name
        missing_names = case lookupNameEnv local_export_env name of
                          Nothing    -> [name]
                          Just avail -> availNames boot_avail `minusList` availNames avail
dterei's avatar
dterei committed
675

676
677
    dfun_names = map getName boot_insts

678
679
    local_export_env :: NameEnv AvailInfo
    local_export_env = availsToNameEnv local_exports
680

681
    check_inst :: ClsInst -> TcM (Maybe (Id, Id))
dterei's avatar
dterei committed
682
        -- Returns a pair of the boot dfun in terms of the equivalent real dfun
683
    check_inst boot_inst
dterei's avatar
dterei committed
684
        = case [dfun | inst <- local_insts,
dterei's avatar
dterei committed
685
686
687
                       let dfun = instanceDFunId inst,
                       idType dfun `eqType` boot_inst_ty ] of
            [] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts)
688
689
                                                  , text "boot_inst"   <+> ppr boot_inst
                                                  , text "boot_inst_ty" <+> ppr boot_inst_ty
dterei's avatar
dterei committed
690
                                                  ])
691
                     ; addErrTc (instMisMatch boot_inst); return Nothing }
dterei's avatar
dterei committed
692
693
694
695
696
            (dfun:_) -> return (Just (local_boot_dfun, dfun))
        where
          boot_dfun = instanceDFunId boot_inst
          boot_inst_ty = idType boot_dfun
          local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty
697

698

699
700
701
702
703
704
705
706
707
708
-- This has to compare the TyThing from the .hi-boot file to the TyThing
-- in the current source file.  We must be careful to allow alpha-renaming
-- where appropriate, and also the boot declaration is allowed to omit
-- constructors and class methods.
--
-- See rnfail055 for a good test of this stuff.

checkBootDecl :: TyThing -> TyThing -> Bool

checkBootDecl (AnId id1) (AnId id2)
dterei's avatar
dterei committed
709
  = ASSERT(id1 == id2)
710
    (idType id1 `eqType` idType id2)
711
712

checkBootDecl (ATyCon tc1) (ATyCon tc2)
713
714
  = checkBootTyCon tc1 tc2

batterseapower's avatar
batterseapower committed
715
716
717
718
719
720
721
722
723
checkBootDecl (ADataCon dc1) (ADataCon _)
  = pprPanic "checkBootDecl" (ppr dc1)

checkBootDecl _ _ = False -- probably shouldn't happen

----------------
checkBootTyCon :: TyCon -> TyCon -> Bool
checkBootTyCon tc1 tc2
  | not (eqKind (tyConKind tc1) (tyConKind tc2))
dterei's avatar
dterei committed
724
  = False       -- First off, check the kind
batterseapower's avatar
batterseapower committed
725
726
727

  | Just c1 <- tyConClass_maybe tc1
  , Just c2 <- tyConClass_maybe tc2
728
  , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1)
729
          = classExtraBigSig c1
730
        (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2)
731
          = classExtraBigSig c2
732
733
  , Just env <- eqTyVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2
  = let
734
735
       eqSig (id1, def_meth1) (id2, def_meth2)
         = idName id1 == idName id2 &&
736
           eqTypeX env op_ty1 op_ty2 &&
737
           def_meth1 == def_meth2
738
         where
batterseapower's avatar
batterseapower committed
739
740
741
          (_, rho_ty1) = splitForAllTys (idType id1)
          op_ty1 = funResultTy rho_ty1
          (_, rho_ty2) = splitForAllTys (idType id2)
742
743
          op_ty2 = funResultTy rho_ty2

744
745
746
747
       eqAT (tc1, def_ats1) (tc2, def_ats2)
         = checkBootTyCon tc1 tc2 &&
           eqListBy eqATDef def_ats1 def_ats2

dreixel's avatar
dreixel committed
748
       -- Ignore the location of the defaults
749
750
       eqATDef (CoAxBranch { cab_tvs = tvs1, cab_lhs =  ty_pats1, cab_rhs = ty1 })
               (CoAxBranch { cab_tvs = tvs2, cab_lhs =  ty_pats2, cab_rhs = ty2 })
751
752
         | Just env <- eqTyVarBndrs emptyRnEnv2 tvs1 tvs2
         = eqListBy (eqTypeX env) ty_pats1 ty_pats2 &&
753
           eqTypeX env ty1 ty2
754
         | otherwise = False
755

dterei's avatar
dterei committed
756
       eqFD (as1,bs1) (as2,bs2) =
757
758
         eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
         eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
759
    in
batterseapower's avatar
batterseapower committed
760
             -- Checks kind of class
761
762
763
       eqListBy eqFD clas_fds1 clas_fds2 &&
       (null sc_theta1 && null op_stuff1 && null ats1
        ||   -- Above tests for an "abstract" class
764
        eqListBy (eqPredX env) sc_theta1 sc_theta2 &&
765
        eqListBy eqSig op_stuff1 op_stuff2 &&
dterei's avatar
dterei committed
766
        eqListBy eqAT ats1 ats2)
767

768
769
  | Just syn_rhs1 <- synTyConRhs_maybe tc1
  , Just syn_rhs2 <- synTyConRhs_maybe tc2
770
  , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
771
  = ASSERT(tc1 == tc2)
772
773
    let eqSynRhs (SynFamilyTyCon o1 i1) (SynFamilyTyCon o2 i2)
            = o1==o2 && i1==i2
774
        eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
775
            = eqTypeX env t1 t2
776
        eqSynRhs _ _ = False
777
    in
778
    eqSynRhs syn_rhs1 syn_rhs2
779
780

  | isAlgTyCon tc1 && isAlgTyCon tc2
781
  , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
782
  = ASSERT(tc1 == tc2)
783
    eqListBy (eqPredX env) (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
784
    eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)
785
786

  | isForeignTyCon tc1 && isForeignTyCon tc2
787
788
  = eqKind (tyConKind tc1) (tyConKind tc2) &&
    tyConExtName tc1 == tyConExtName tc2
789
790

  | otherwise = False
dterei's avatar
dterei committed
791
  where
792
793
794
795
796
797
798
799
800
801
802
803
804
    eqAlgRhs (AbstractTyCon dis1) rhs2
      | dis1      = isDistinctAlgRhs rhs2   --Check compatibility
      | otherwise = True
    eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True
    eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} =
        eqListBy eqCon (data_cons tc1) (data_cons tc2)
    eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} =
        eqCon (data_con tc1) (data_con tc2)
    eqAlgRhs _ _ = False

    eqCon c1 c2
      =  dataConName c1 == dataConName c2
      && dataConIsInfix c1 == dataConIsInfix c2
805
      && eqListBy eqHsBang (dataConStrictMarks c1) (dataConStrictMarks c2)
806
807
808
809
810
      && dataConFieldLabels c1 == dataConFieldLabels c2
      && eqType (dataConUserType c1) (dataConUserType c2)

emptyRnEnv2 :: RnEnv2
emptyRnEnv2 = mkRnEnv2 emptyInScopeSet
811

812
----------------
813
814
missingBootThing :: Name -> String -> SDoc
missingBootThing name what
dterei's avatar
dterei committed
815
  = ppr name <+> ptext (sLit "is exported by the hs-boot file, but not")
dterei's avatar
dterei committed
816
              <+> text what <+> ptext (sLit "the module")
817

818
bootMisMatch :: TyThing -> IfaceDecl -> IfaceDecl -> SDoc
819
bootMisMatch thing boot_decl real_decl
Ian Lynagh's avatar
Ian Lynagh committed
820
  = vcat [ppr thing <+> ptext (sLit "has conflicting definitions in the module and its hs-boot file"),
dterei's avatar
dterei committed
821
822
          ptext (sLit "Main module:") <+> ppr real_decl,
          ptext (sLit "Boot file:  ") <+> ppr boot_decl]
823

824
instMisMatch :: ClsInst -> SDoc
825
instMisMatch inst
826
  = hang (ppr inst)
Ian Lynagh's avatar
Ian Lynagh committed
827
       2 (ptext (sLit "is defined in the hs-boot file, but not in the module itself"))
828
829
\end{code}

830

831
%************************************************************************
dterei's avatar
dterei committed
832
833
834
%*                                                                      *
        Type-checking the top level of a module
%*                                                                      *
835
836
837
838
839
840
841
842
843
844
845
846
%************************************************************************

tcRnGroup takes a bunch of top-level source-code declarations, and
 * renames them
 * gets supporting declarations from interface files
 * typechecks them
 * zonks them
 * and augments the TcGblEnv with the results

In Template Haskell it may be called repeatedly for each group of
declarations.  It expects there to be an incoming TcGblEnv in the
monad; it augments it and returns the new TcGblEnv.
847
848

\begin{code}
849
------------------------------------------------
850
rnTopSrcDecls :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
851
-- Fails if there are any errors
852
rnTopSrcDecls extra_deps group
853
 = do { -- Rename the source decls
854
        traceTc "rn12" empty ;
dterei's avatar
dterei committed
855
        (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls extra_deps group ;
856
        traceTc "rn13" empty ;
857

858
        -- save the renamed syntax, if we want it
dterei's avatar
dterei committed
859
860
861
862
863
        let { tcg_env'
                | Just grp <- tcg_rn_decls tcg_env
                  = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
                | otherwise
                   = tcg_env };
864

dterei's avatar
dterei committed
865
866
                -- Dump trace of renaming part
        rnDump (ppr rn_decls) ;
867

dterei's avatar
dterei committed
868
        return (tcg_env', rn_decls)
869
   }
870

871
------------------------------------------------
872
tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
dterei's avatar
dterei committed
873
874
tcTopSrcDecls boot_details
        (HsGroup { hs_tyclds = tycl_decls,
dterei's avatar
dterei committed
875
                   hs_instds = inst_decls,
876
                   hs_derivds = deriv_decls,
dterei's avatar
dterei committed
877
878
879
880
881
882
883
884
                   hs_fords  = foreign_decls,
                   hs_defds  = default_decls,
                   hs_annds  = annotation_decls,
                   hs_ruleds = rule_decls,
                   hs_vects  = vect_decls,
                   hs_valds  = val_binds })
 = do {         -- Type-check the type and class decls, and all imported decls
                -- The latter come in via tycl_decls
885
        traceTc "Tc2 (src)" empty ;
886

dterei's avatar
dterei committed
887
888
                -- Source-language instances, including derivings,
                -- and import the supporting declarations
889
        traceTc "Tc3" empty ;
dterei's avatar
dterei committed
890
        (tcg_env, inst_infos, deriv_binds)
891
            <- tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls ;
dterei's avatar
dterei committed
892
        setGblEnv tcg_env       $ do {
893

dterei's avatar
dterei committed
894
                -- Foreign import declarations next.
895
        traceTc "Tc4" empty ;
896
        (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ;
dterei's avatar
dterei committed
897
        tcExtendGlobalValEnv fi_ids     $ do {
898

dterei's avatar
dterei committed
899
                -- Default declarations
900
        traceTc "Tc4a" empty ;
dterei's avatar
dterei committed
901
902
        default_tys <- tcDefaults default_decls ;
        updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
dterei's avatar
dterei committed
903

dterei's avatar
dterei committed
904
905
906
907
                -- Now GHC-generated derived bindings, generics, and selectors
                -- Do not generate warnings from compiler-generated code;
                -- hence the use of discardWarnings
        tc_envs <- discardWarnings (tcTopBinds deriv_binds) ;
908
        setEnvs tc_envs $ do {
909

dterei's avatar
dterei committed
910
                -- Value declarations next
911
        traceTc "Tc5" empty ;
dterei's avatar
dterei committed
912
913
        tc_envs@(tcg_env, tcl_env) <- tcTopBinds val_binds;
        setEnvs tc_envs $ do {  -- Environment doesn't change now
914

dterei's avatar
dterei committed
915
                -- Second pass over class and instance declarations,
916
                -- now using the kind-checked decls
917
        traceTc "Tc6" empty ;
918
        inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
919

920
                -- Foreign exports
921
        traceTc "Tc7" empty ;
922
        (foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ;
923

924
                -- Annotations
925
        annotations <- tcAnnotations annotation_decls ;
926

927
928
                -- Rules
        rules <- tcRules rule_decls ;
929