TcRnDriver.lhs 77.9 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 )
45 46 47 48 49 50
import TcDefaults
import TcEnv
import TcRules
import TcForeign
import TcInstDcls
import TcIface
51
import TcMType
52
import MkIface
53
import IfaceSyn
54 55 56 57 58 59 60 61 62 63
import TcSimplify
import TcTyClsDecls
import LoadIface
import RnNames
import RnEnv
import RnSource
import PprCore
import CoreSyn
import ErrUtils
import Id
64
import VarEnv
Simon Marlow's avatar
Simon Marlow committed
65
import Module
66
import UniqFM
67
import Name
68
import NameEnv
69
import NameSet
70
import Avail
71 72 73
import TyCon
import SrcLoc
import HscTypes
74
import ListSetOps
75
import Outputable
76 77 78
import DataCon
import Type
import Class
79
import CoAxiom  ( CoAxBranch(..) )
80
import TcType   ( orphNamesOfDFunHead )
dterei's avatar
dterei committed
81
import Inst     ( tcGetInstEnvs )
82
import Data.List ( sortBy )
GregWeber's avatar
GregWeber committed
83
import Data.IORef ( readIORef )
84
import Data.Ord
85

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

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

103
import Control.Monad
104

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

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


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

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

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

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

   initTc hsc_env hsc_src save_rn_syntax this_mod $
144
   setSrcSpan loc $
dterei's avatar
dterei committed
145
   do {         -- Deal with imports; first add implicit prelude
146 147 148 149
        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
150
        whenWOptM Opt_WarnImplicitPrelude $
151 152
             when (notNull prel_imports) $ addWarn (implicitPreludeWarn) ;

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

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

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

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

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

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

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

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

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

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

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


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


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

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

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

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

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

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


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

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

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

316
   initTc hsc_env ExtCoreFile False this_mod $ do {
317

318
   let { ldecls  = map noLoc decls } ;
319

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

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

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

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

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

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

GregWeber's avatar
GregWeber committed
352

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

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

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

389
   tcCoreDump mod_guts ;
390

391 392
   return mod_guts
   }}}}
393

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


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

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

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

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

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

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

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

464
        setGlobalTypeEnv tcg_env' final_type_env
465
   } }
466

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

678 679
    dfun_names = map getName boot_insts

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

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

700

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

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

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

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

746 747 748 749
       eqAT (tc1, def_ats1) (tc2, def_ats2)
         = checkBootTyCon tc1 tc2 &&
           eqListBy eqATDef def_ats1 def_ats2

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

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

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

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

  | isForeignTyCon tc1 && isForeignTyCon tc2
789 790
  = eqKind (tyConKind tc1) (tyConKind tc2) &&
    tyConExtName tc1 == tyConExtName tc2
791 792

  | otherwise = False
dterei's avatar
dterei committed
793
  where
794 795 796 797 798 799 800 801 802 803 804 805 806
    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
807
      && eqListBy eqHsBang (dataConStrictMarks c1) (dataConStrictMarks c2)
808 809 810 811 812
      && dataConFieldLabels c1 == dataConFieldLabels c2
      && eqType (dataConUserType c1) (dataConUserType c2)

emptyRnEnv2 :: RnEnv2
emptyRnEnv2 = mkRnEnv2 emptyInScopeSet
813

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