TcRnDriver.lhs 76.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

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

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

99
import FastString
100
import Maybes
101
102
import Util
import Bag
103

104
import Control.Monad
105

106
#include "HsVersions.h"
107
108
109
\end{code}

%************************************************************************
dterei's avatar
dterei committed
110
111
112
%*                                                                      *
        Typecheck and rename a module
%*                                                                      *
113
114
115
116
%************************************************************************


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

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

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

dterei's avatar
dterei committed
141
                Just (L mod_loc mod)  -- The normal case
142
                    -> (mkModule this_pkg mod, mod_loc) } ;
dterei's avatar
dterei committed
143
144

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

        ifWOptM Opt_WarnImplicitPrelude $
             when (notNull prel_imports) $ addWarn (implicitPreludeWarn) ;

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

          -- 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
166
167
168

                -- 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
169
                -- to tcTyAndClassDecls, because the boot_names are
dterei's avatar
dterei committed
170
171
172
173
174
175
176
177
178
179
180
                -- 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
181
                   else
dterei's avatar
dterei committed
182
                        {-# SCC "tcRnSrcDecls" #-}
183
                        tcRnSrcDecls boot_iface local_decls ;
dterei's avatar
dterei committed
184
185
186
        setGblEnv tcg_env               $ do {

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

191
192
193
                -- Check that main is exported (must be after rnExports)
        checkMainExported tcg_env ;

dterei's avatar
dterei committed
194
195
196
        -- 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 ;
197

dterei's avatar
dterei committed
198
        -- The new type env is already available to stuff slurped from
dterei's avatar
dterei committed
199
        -- interface files, via TcEnv.updateGlobalTypeEnv
dterei's avatar
dterei committed
200
201
        -- 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
202
        -- which may be mentioned in imported unfoldings
203

dterei's avatar
dterei committed
204
205
206
                -- 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 }) ;
207

dterei's avatar
dterei committed
208
209
                -- Report unused names
        reportUnusedNames export_ies tcg_env ;
210

211
212
213
214
                -- add extra source files to tcg_dependent_files
        addDependentFiles src_files ;

                -- Dump output and return
dterei's avatar
dterei committed
215
216
        tcDump tcg_env ;
        return tcg_env
Simon Marlow's avatar
Simon Marlow committed
217
    }}}}
218
219
220
221
222


implicitPreludeWarn :: SDoc
implicitPreludeWarn
  = ptext (sLit "Module `Prelude' implicitly imported")
223
224
225
\end{code}


226
%************************************************************************
dterei's avatar
dterei committed
227
228
229
%*                                                                      *
                Import declarations
%*                                                                      *
230
231
232
%************************************************************************

\begin{code}
dterei's avatar
dterei committed
233
tcRnImports :: HscEnv -> Module
234
            -> [LImportDecl RdrName] -> TcM TcGblEnv
235
tcRnImports hsc_env this_mod import_decls
dterei's avatar
dterei committed
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
  = 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
256
              ; (home_insts, home_fam_insts) = hptInstances hsc_env
257
                                                            want_instances
dterei's avatar
dterei committed
258
              } ;
259

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

dterei's avatar
dterei committed
265
                -- Update the gbl env
dterei's avatar
dterei committed
266
267
        ; updGblEnv ( \ gbl ->
            gbl {
268
              tcg_rdr_env      = plusOccEnv (tcg_rdr_env gbl) rdr_env,
dterei's avatar
dterei committed
269
              tcg_imports      = tcg_imports gbl `plusImportAvails` imports,
270
              tcg_rn_imports   = rn_imports,
dterei's avatar
dterei committed
271
              tcg_inst_env     = extendInstEnvList (tcg_inst_env gbl) home_insts,
dterei's avatar
dterei committed
272
              tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
273
                                                      home_fam_insts,
dterei's avatar
dterei committed
274
275
276
277
278
              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
279
                -- The error printing (if needed) takes advantage
dterei's avatar
dterei committed
280
281
282
283
284
285
286
                -- 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
287
        ; loadModuleInterfaces (ptext (sLit "Loading orphan modules"))
288
                               (imp_orphs imports)
289

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

dterei's avatar
dterei committed
297
        ; getGblEnv } }
298
299
300
\end{code}


301
%************************************************************************
dterei's avatar
dterei committed
302
303
304
%*                                                                      *
        Type-checking external-core modules
%*                                                                      *
305
306
307
%************************************************************************

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

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

317
   initTc hsc_env ExtCoreFile False this_mod $ do {
318

319
   let { ldecls  = map noLoc decls } ;
320

321
       -- Bring the type and class decls into scope
322
323
       -- 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
324
       --          (a) tcTyAndClassDecls doesn't need the val binds, and
325
326
327
       --          (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
328
   (tc_envs, _bndrs) <- getLocalNonValBinders emptyFsEnv {- no fixity decls -}
329
                                              (mkFakeGroup ldecls) ;
330
   setEnvs tc_envs $ do {
331

332
333
334
   (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
335

dterei's avatar
dterei committed
336
        -- Dump trace of renaming part
337
   rnDump (ppr rn_decls) ;
338

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

347
   setGblEnv tcg_env $ do {
dterei's avatar
dterei committed
348
        -- Make the new type env available to stuff slurped from interface files
dterei's avatar
dterei committed
349

dterei's avatar
dterei committed
350
        -- Now the core bindings
351
   core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
352

GregWeber's avatar
GregWeber committed
353

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

360
        mod_guts = ModGuts {    mg_module    = this_mod,
dterei's avatar
dterei committed
361
                                mg_boot      = False,
362
                                mg_used_names = emptyNameSet, -- ToDo: compute usage
363
364
                                mg_used_th   = False,
                                mg_dir_imps  = emptyModuleEnv, -- ??
dterei's avatar
dterei committed
365
                                mg_deps      = noDependencies,  -- ??
366
367
368
369
370
371
                                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,
372
373
374
375
                                mg_rules        = [],
                                mg_vect_decls   = [],
                                mg_anns         = [],
                                mg_binds        = core_binds,
376
377

                                -- Stubs
378
379
380
381
382
383
384
385
386
                                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
387
                                mg_dependent_files = dep_files
388
                            } } ;
389

390
   tcCoreDump mod_guts ;
391

392
393
   return mod_guts
   }}}}
394

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


401
%************************************************************************
dterei's avatar
dterei committed
402
403
404
%*                                                                      *
        Type-checking the top level of a module
%*                                                                      *
405
%************************************************************************
406

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

dterei's avatar
dterei committed
418
             --         Finish simplifying class constraints
dterei's avatar
dterei committed
419
420
             --
             -- simplifyTop deals with constant or ambiguous InstIds.
dterei's avatar
dterei committed
421
422
423
424
             -- 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
425
             -- We do this after checkMain, so that we use the type info
dterei's avatar
dterei committed
426
             -- that checkMain adds
dterei's avatar
dterei committed
427
             --
dterei's avatar
dterei committed
428
429
             -- We do it with both global and local env in scope:
             --  * the global env exposes the instances to simplifyTop
dterei's avatar
dterei committed
430
             --  * the local env exposes the local Ids to simplifyTop,
dterei's avatar
dterei committed
431
432
             --    so that we get better error messages (monomorphism restriction)
        new_ev_binds <- {-# SCC "simplifyTop" #-}
433
                        simplifyTop lie ;
434
        traceTc "Tc9" empty ;
435

dterei's avatar
dterei committed
436
437
438
        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!
439

440
441
        -- Zonk the final code.  This must be done last.
        -- Even simplifyTop may do some unification.
442
        -- This pass also warns about missing type signatures
443
        let { TcGblEnv { tcg_type_env  = type_env,
444
445
446
447
448
449
450
                         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
451
            ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
452

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

457
458
459
460
        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
461
462
                                   tcg_rules    = rules',
                                   tcg_vects    = vects',
463
464
                                   tcg_fords    = fords' } } ;

465
        setGlobalTypeEnv tcg_env' final_type_env
466
   } }
467

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

        -- The extra_deps are needed while renaming type and class declarations
479
        -- See Note [Extra dependencies from .hs-boot files] in RnSource
dterei's avatar
dterei committed
480
481
482
483
        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
484
485

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

dterei's avatar
dterei committed
488
        -- If there is no splice, we're nearly done
dterei's avatar
dterei committed
489
        setEnvs (tcg_env, tcl_env) $
dterei's avatar
dterei committed
490
491
        case group_tail of {
           Nothing -> do { tcg_env <- checkMain ;       -- Check for `main'
dterei's avatar
dterei committed
492
                           return (tcg_env, tcl_env)
dterei's avatar
dterei committed
493
                      } ;
494
495

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

dterei's avatar
dterei committed
503
504
505
506
        -- 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) ;
507

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

dterei's avatar
dterei committed
511
512
513
        -- 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)
514
#endif /* GHCI */
515
    } } }
516
517
\end{code}

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

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

dterei's avatar
dterei committed
530
                -- Rename the declarations
dterei's avatar
dterei committed
531
532
        ; (tcg_env, HsGroup {
                   hs_tyclds = tycl_decls,
dterei's avatar
dterei committed
533
534
535
                   hs_instds = inst_decls,
                   hs_derivds = deriv_decls,
                   hs_fords  = for_decls,
dterei's avatar
dterei committed
536
537
538
                   hs_defds  = def_decls,
                   hs_ruleds = rule_decls,
                   hs_vects  = vect_decls,
dterei's avatar
dterei committed
539
540
                   hs_annds  = _,
                   hs_valds  = val_binds }) <- rnTopSrcDecls [] first_group
541
542
        -- 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
543
544
545
546
547
548
549
550
551
552
553
554
        ; (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

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

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

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

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

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

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

589
590
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).
591
592

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

602
checkHiBootIface
dterei's avatar
dterei committed
603
        tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds,
dterei's avatar
dterei committed
604
                            tcg_insts = local_insts,
dterei's avatar
dterei committed
605
606
607
608
                            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
609
  = return tcg_env
610
611

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

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

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

dterei's avatar
dterei committed
626
627
                -- Check instance declarations
        ; mb_dfun_prs <- mapM check_inst boot_insts
628
629
630
631
632
633
        ; 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 }
634

635
        ; failIfErrsM
dterei's avatar
dterei committed
636
637
        ; setGlobalTypeEnv tcg_env' type_env' }
             -- Update the global type env *including* the knot-tied one
638
639
640
             -- 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
641
  where
dterei's avatar
dterei committed
642
    check_export boot_avail     -- boot_avail is exported by the boot iface
dterei's avatar
dterei committed
643
      | name `elem` dfun_names = return ()
dterei's avatar
dterei committed
644
645
646
      | 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)
647

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

dterei's avatar
dterei committed
653
654
        -- 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)
655
      | isNothing mb_boot_thing = return ()
656

dterei's avatar
dterei committed
657
        -- Check that the actual module also defines the thing, and
dterei's avatar
dterei committed
658
        -- then compare the definitions
659
660
661
662
      | 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
663
                       (let boot_decl = tyThingToIfaceDecl
664
665
666
                                               (fromJust mb_boot_thing)
                            real_decl = tyThingToIfaceDecl real_thing
                        in bootMisMatch real_thing boot_decl real_decl)
667

668
      | otherwise
669
      = addErrTc (missingBootThing name "defined in")
670
      where
dterei's avatar
dterei committed
671
672
673
674
675
        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
676

677
678
    dfun_names = map getName boot_insts

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

682
    check_inst :: ClsInst -> TcM (Maybe (Id, Id))
dterei's avatar
dterei committed
683
        -- Returns a pair of the boot dfun in terms of the equivalent real dfun
684
    check_inst boot_inst
dterei's avatar
dterei committed
685
        = case [dfun | inst <- local_insts,
dterei's avatar
dterei committed
686
687
688
                       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)
689
690
                                                  , text "boot_inst"   <+> ppr boot_inst
                                                  , text "boot_inst_ty" <+> ppr boot_inst_ty
dterei's avatar
dterei committed
691
                                                  ])
692
                     ; addErrTc (instMisMatch boot_inst); return Nothing }
dterei's avatar
dterei committed
693
694
695
696
697
            (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
698

699

700
701
702
703
704
705
706
707
708
709
-- 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
710
  = ASSERT(id1 == id2)
711
    (idType id1 `eqType` idType id2)
712
713

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

batterseapower's avatar
batterseapower committed
716
717
718
719
720
721
722
723
724
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
725
  = False       -- First off, check the kind
batterseapower's avatar
batterseapower committed
726
727
728

  | Just c1 <- tyConClass_maybe tc1
  , Just c2 <- tyConClass_maybe tc2
dterei's avatar
dterei committed
729
730
  = let
       (clas_tyvars1, clas_fds1, sc_theta1, _, ats1, op_stuff1)
731
          = classExtraBigSig c1
dterei's avatar
dterei committed
732
       (clas_tyvars2, clas_fds2, sc_theta2, _, ats2, op_stuff2)
733
734
735
736
737
738
739
          = classExtraBigSig c2

       env0 = mkRnEnv2 emptyInScopeSet
       env = rnBndrs2 env0 clas_tyvars1 clas_tyvars2

       eqSig (id1, def_meth1) (id2, def_meth2)
         = idName id1 == idName id2 &&
740
           eqTypeX env op_ty1 op_ty2 &&
741
           def_meth1 == def_meth2
742
         where
batterseapower's avatar
batterseapower committed
743
744
745
          (_, rho_ty1) = splitForAllTys (idType id1)
          op_ty1 = funResultTy rho_ty1
          (_, rho_ty2) = splitForAllTys (idType id2)
746
747
          op_ty2 = funResultTy rho_ty2

748
749
750
751
       eqAT (tc1, def_ats1) (tc2, def_ats2)
         = checkBootTyCon tc1 tc2 &&
           eqListBy eqATDef def_ats1 def_ats2

dreixel's avatar
dreixel committed
752
753
       -- Ignore the location of the defaults
       eqATDef (ATD tvs1 ty_pats1 ty1 _loc1) (ATD tvs2 ty_pats2 ty2 _loc2)
754
755
756
757
758
         = eqListBy same_kind tvs1 tvs2 &&
           eqListBy (eqTypeX env) ty_pats1 ty_pats2 &&
           eqTypeX env ty1 ty2
         where env = rnBndrs2 env0 tvs1 tvs2

dterei's avatar
dterei committed
759
       eqFD (as1,bs1) (as2,bs2) =
760
761
         eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
         eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
762
763
764
765

       same_kind tv1 tv2 = eqKind (tyVarKind tv1) (tyVarKind tv2)
    in
       eqListBy same_kind clas_tyvars1 clas_tyvars2 &&
batterseapower's avatar
batterseapower committed
766
             -- Checks kind of class
767
768
769
       eqListBy eqFD clas_fds1 clas_fds2 &&
       (null sc_theta1 && null op_stuff1 && null ats1
        ||   -- Above tests for an "abstract" class
770
        eqListBy (eqPredX env) sc_theta1 sc_theta2 &&
771
        eqListBy eqSig op_stuff1 op_stuff2 &&
dterei's avatar
dterei committed
772
        eqListBy eqAT ats1 ats2)
773

774
775
776
777
778
  | isSynTyCon tc1 && isSynTyCon tc2
  = ASSERT(tc1 == tc2)
    let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2
        env = rnBndrs2 env0 tvs1 tvs2

779
780
        eqSynRhs SynFamilyTyCon SynFamilyTyCon
            = True
781
        eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
782
            = eqTypeX env t1 t2
783
        eqSynRhs _ _ = False
784
785
786
787
788
789
    in
    equalLength tvs1 tvs2 &&
    eqSynRhs (synTyConRhs tc1) (synTyConRhs tc2)

  | isAlgTyCon tc1 && isAlgTyCon tc2
  = ASSERT(tc1 == tc2)
790
    eqKind (tyConKind tc1) (tyConKind tc2) &&
791
    eqListBy eqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
792
    eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)
793
794

  | isForeignTyCon tc1 && isForeignTyCon tc2
795
796
  = eqKind (tyConKind tc1) (tyConKind tc2) &&
    tyConExtName tc1 == tyConExtName tc2
797
798

  | otherwise = False
dterei's avatar
dterei committed
799
  where
800
801
        env0 = mkRnEnv2 emptyInScopeSet

dterei's avatar
dterei committed
802
        eqAlgRhs (AbstractTyCon dis1) rhs2
dterei's avatar
dterei committed
803
          | dis1      = isDistinctAlgRhs rhs2   --Check compatibility
804
          | otherwise = True
805
        eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True
806
807
808
809
810
811
812
813
814
815
816
        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
          && dataConStrictMarks c1 == dataConStrictMarks c2
          && dataConFieldLabels c1 == dataConFieldLabels c2
817
          && eqType (dataConUserType c1) (dataConUserType c2)
818

819
----------------
820
821
missingBootThing :: Name -> String -> SDoc
missingBootThing name what
dterei's avatar
dterei committed
822
  = ppr name <+> ptext (sLit "is exported by the hs-boot file, but not")
dterei's avatar
dterei committed
823
              <+> text what <+> ptext (sLit "the module")
824

825
bootMisMatch :: TyThing -> IfaceDecl -> IfaceDecl -> SDoc
826
bootMisMatch thing boot_decl real_decl
Ian Lynagh's avatar
Ian Lynagh committed
827
  = vcat [ppr thing <+> ptext (sLit "has conflicting definitions in the module and its hs-boot file"),
dterei's avatar
dterei committed
828
829
          ptext (sLit "Main module:") <+> ppr real_decl,
          ptext (sLit "Boot file:  ") <+> ppr boot_decl]
830

831
instMisMatch :: ClsInst -> SDoc
832
instMisMatch inst
833
  = hang (ppr inst)
Ian Lynagh's avatar
Ian Lynagh committed
834
       2 (ptext (sLit "is defined in the hs-boot file, but not in the module itself"))
835
836
\end{code}

837

838
%************************************************************************
dterei's avatar
dterei committed
839
840
841
%*                                                                      *
        Type-checking the top level of a module
%*                                                                      *
842
843
844
845
846
847
848
849
850
851
852
853
%************************************************************************

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.
854
855

\begin{code}
856
------------------------------------------------
857
rnTopSrcDecls :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
858
-- Fails if there are any errors
859
rnTopSrcDecls extra_deps group
860
 = do { -- Rename the source decls
861
        traceTc "rn12" empty ;
dterei's avatar
dterei committed
862
        (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls extra_deps group ;
863
        traceTc "rn13" empty ;
864

865
        -- save the renamed syntax, if we want it
dterei's avatar
dterei committed
866
867
868
869
870
        let { tcg_env'
                | Just grp <- tcg_rn_decls tcg_env
                  = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
                | otherwise
                   = tcg_env };
871

dterei's avatar
dterei committed
872
873
                -- Dump trace of renaming part
        rnDump (ppr rn_decls) ;
874

dterei's avatar
dterei committed
875
        return (tcg_env', rn_decls)
876
   }
877

878
------------------------------------------------
879
tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
dterei's avatar
dterei committed
880
881
tcTopSrcDecls boot_details
        (HsGroup { hs_tyclds = tycl_decls,
dterei's avatar
dterei committed
882
                   hs_instds = inst_decls,
883
                   hs_derivds = deriv_decls,
dterei's avatar
dterei committed
884
885
886
887
888
889
890
891
                   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
892
        traceTc "Tc2 (src)" empty ;
893

dterei's avatar
dterei committed
894
895
                -- Source-language instances, including derivings,
                -- and import the supporting declarations
896
        traceTc "Tc3" empty ;
dterei's avatar
dterei committed
897
        (tcg_env, inst_infos, deriv_binds)
898
            <- tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls ;
dterei's avatar
dterei committed
899
        setGblEnv tcg_env       $ do {
900

dterei's avatar
dterei committed
901
                -- Foreign import declarations next.
902
        traceTc "Tc4" empty ;
dterei's avatar
dterei committed
903
904
        (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
        tcExtendGlobalValEnv fi_ids     $ do {
905

dterei's avatar
dterei committed
906
                -- Default declarations
907
        traceTc "Tc4a" empty ;
dterei's avatar
dterei committed
908
909
        default_tys <- tcDefaults default_decls ;
        updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
dterei's avatar
dterei committed
910

dterei's avatar
dterei committed
911
912
913
914
                -- 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) ;
915
        setEnvs tc_envs $ do {
916

dterei's avatar
dterei committed
917
                -- Value declarations next
918
        traceTc "Tc5" empty ;
dterei's avatar
dterei committed
919
920
        tc_envs@(tcg_env, tcl_env) <- tcTopBinds val_binds;
        setEnvs tc_envs $ do {  -- Environment doesn't change now
921

dterei's avatar
dterei committed
922
                -- Second pass over class and instance declarations,
923
                -- now using the kind-checked decls
924
        traceTc "Tc6" empty ;
925
        inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
926

927
                -- Foreign exports
928
        traceTc "Tc7" empty ;
929
        (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
930

931
                -- Annotations
932
        annotations <- tcAnnotations annotation_decls ;
933

934
935
                -- Rules
        rules <- tcRules rule_decls ;
936

937
938
939
940
                -- Vectorisation declarations
        vects <- tcVectDecls vect_decls ;

                -- Wrap up