TcRnDriver.hs 91.6 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

5
\section[TcMovectle]{Typechecking a whole module}
6 7

https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TypeChecker
Austin Seipp's avatar
Austin Seipp committed
8
-}
9

10 11
{-# LANGUAGE CPP, NondecreasingIndentation #-}

12 13
module TcRnDriver (
#ifdef GHCI
dterei's avatar
dterei committed
14 15 16 17 18
        tcRnStmt, tcRnExpr, tcRnType,
        tcRnImportDecls,
        tcRnLookupRdrName,
        getModuleInterface,
        tcRnDeclsi,
dterei's avatar
dterei committed
19
        isGHCiMonad,
20
        runTcInteractive,    -- Used by GHC API clients (Trac #8878)
21
#endif
dterei's avatar
dterei committed
22 23
        tcRnLookupName,
        tcRnGetInfo,
24
        tcRnModule, tcRnModuleTcRnM,
Adam Gundry's avatar
Adam Gundry committed
25
        tcTopSrcDecls,
26 27
    ) where

28
#ifdef GHCI
29 30
import {-# SOURCE #-} TcSplice ( runQuasi )
import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )
31 32 33 34 35 36 37 38 39 40 41
import IfaceEnv( externaliseName )
import TcType   ( isUnitTy, isTauTy )
import TcHsType
import TcMatches
import RnTypes
import RnExpr
import MkId
import TidyPgm    ( globaliseAndTidyId )
import TysWiredIn ( unitTy, mkListTy )
import DynamicLoading ( loadPlugins )
import Plugins ( tcPlugin )
42 43
#endif

44 45 46 47 48 49 50
import DynFlags
import StaticFlags
import HsSyn
import PrelNames
import RdrName
import TcHsSyn
import TcExpr
51
import TcRnMonad
52
import TcEvidence
53 54
import PprTyThing( pprTyThing )
import Coercion( pprCoAxiom )
55
import FamInst
56 57
import InstEnv
import FamInstEnv
58
import TcAnnotations
59
import TcBinds
60
import HeaderInfo       ( mkPrelImports )
61 62 63 64 65 66
import TcDefaults
import TcEnv
import TcRules
import TcForeign
import TcInstDcls
import TcIface
67
import TcMType
68 69 70 71
import MkIface
import TcSimplify
import TcTyClsDecls
import LoadIface
72
import TidyPgm    ( mkBootModDetailsTc )
73 74 75 76 77
import RnNames
import RnEnv
import RnSource
import ErrUtils
import Id
78
import IdInfo( IdDetails( VanillaId ) )
79
import VarEnv
Simon Marlow's avatar
Simon Marlow committed
80
import Module
81
import UniqFM
82
import Name
83
import NameEnv
84
import NameSet
85
import Avail
86 87 88
import TyCon
import SrcLoc
import HscTypes
89
import ListSetOps
90
import Outputable
Gergő Érdi's avatar
Gergő Érdi committed
91
import ConLike
92 93 94
import DataCon
import Type
import Class
95
import BasicTypes hiding( SuccessFlag(..) )
96
import CoAxiom
97
import Annotations
98
import Data.List ( sortBy )
99
import Data.Ord
100
import FastString
101
import Maybes
102 103
import Util
import Bag
104

105
import Control.Monad
106

107
#include "HsVersions.h"
108

Austin Seipp's avatar
Austin Seipp committed
109 110 111
{-
************************************************************************
*                                                                      *
dterei's avatar
dterei committed
112
        Typecheck and rename a module
Austin Seipp's avatar
Austin Seipp committed
113 114 115
*                                                                      *
************************************************************************
-}
116

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
   parsedModule@HsParsedModule {hpm_module=L loc this_module}
126
 | RealSrcSpan real_loc <- loc
127 128
 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;

129 130 131
      ; initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $
               withTcPlugins hsc_env $
               tcRnModuleTcRnM hsc_env hsc_src parsedModule pair }
dterei's avatar
dterei committed
132

133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148
  | otherwise
  = return ((emptyBag, unitBag err_msg), Nothing)

  where
    err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $
              text "Module does not have a RealSrcSpan:" <+> ppr this_mod

    this_pkg = thisPackage (hsc_dflags hsc_env)

    pair :: (Module, SrcSpan)
    pair@(this_mod,_)
      | Just (L mod_loc mod) <- hsmodName this_module
      = (mkModule this_pkg mod, mod_loc)

      | otherwise   -- 'module M where' is omitted
      = (mAIN, srcLocSpan (srcSpanStart loc))
dterei's avatar
dterei committed
149

150

151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170
-- To be called at the beginning of renaming hsig files.
-- If we're processing a signature, load up the RdrEnv
-- specified by sig-of so that
-- when we process top-level bindings, we pull in the right
-- original names.  We also need to add in dependencies from
-- the implementation (orphans, family instances, packages),
-- similar to how rnImportDecl handles things.
-- ToDo: Handle SafeHaskell
tcRnSignature :: DynFlags -> HscSource -> TcRn TcGblEnv
tcRnSignature dflags hsc_src
 = do { tcg_env <- getGblEnv ;
        case tcg_sig_of tcg_env of {
          Just sof
           | hsc_src /= HsigFile -> do
                { addErr (ptext (sLit "Illegal -sig-of specified for non hsig"))
                ; return tcg_env
                }
           | otherwise -> do
            { sig_iface <- initIfaceTcRn $ loadSysInterface (text "sig-of") sof
            ; let { gr = mkGlobalRdrEnv
171
                              (gresFromAvails Nothing (mi_exports sig_iface))
172 173 174 175 176 177 178
                  ; avails = calculateAvails dflags
                                    sig_iface False{- safe -} False{- boot -} }
            ; return (tcg_env
                { tcg_impl_rdr_env = Just gr
                , tcg_imports = tcg_imports tcg_env `plusImportAvails` avails
                })
            } ;
Edward Z. Yang's avatar
Edward Z. Yang committed
179
          Nothing
180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245
             | HsigFile <- hsc_src
             , HscNothing <- hscTarget dflags -> do
                { return tcg_env
                }
             | HsigFile <- hsc_src -> do
                { addErr (ptext (sLit "Missing -sig-of for hsig"))
                ; failM }
             | otherwise -> return tcg_env
        }
      }

checkHsigIface :: HscEnv -> TcGblEnv -> TcRn ()
checkHsigIface hsc_env tcg_env
  = case tcg_impl_rdr_env tcg_env of
      Just gr -> do { sig_details <- liftIO $ mkBootModDetailsTc hsc_env tcg_env
                    ; checkHsigIface' gr sig_details
                    }
      Nothing -> return ()

checkHsigIface' :: GlobalRdrEnv -> ModDetails -> TcRn ()
checkHsigIface' gr
  ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts,
               md_types = sig_type_env, md_exports = sig_exports}
  = do { traceTc "checkHsigIface" $ vcat
           [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ]
       ; mapM_ check_export sig_exports
       ; unless (null sig_fam_insts) $
           panic ("TcRnDriver.checkHsigIface: Cannot handle family " ++
                  "instances in hsig files yet...")
       ; mapM_ check_inst sig_insts
       ; failIfErrsM
       }
  where
    check_export sig_avail
      -- Skip instances, we'll check them later
      | name `elem` dfun_names = return ()
      | otherwise = do
        { -- Lookup local environment only (don't want to accidentally pick
          -- up the backing copy.)  We consult tcg_type_env because we want
          -- to pick up wired in names too (which get dropped by the iface
          -- creation process); it's OK for a signature file to mention
          -- a wired in name.
          env <- getGblEnv
        ; case lookupNameEnv (tcg_type_env env) name of
            Nothing
                -- All this means is no local definition is available: but we
                -- could have created the export this way:
                --
                -- module ASig(f) where
                --      import B(f)
                --
                -- In this case, we have to just lookup the identifier in
                -- the backing implementation and make sure it matches.
                | [GRE { gre_name = name' }]
                    <- lookupGlobalRdrEnv gr (nameOccName name)
                , name == name' -> return ()
                -- TODO: Possibly give a different error if the identifier
                -- is exported, but it's a different original name
                | otherwise -> addErrAt (nameSrcSpan name)
                                (missingBootThing False name "exported by")
            Just sig_thing -> do {
          -- We use tcLookupImported_maybe because we want to EXCLUDE
          -- tcg_env.
        ; r <- tcLookupImported_maybe name
        ; case r of
            Failed err -> addErr err
246
            Succeeded real_thing -> checkBootDeclM False sig_thing real_thing
247 248 249 250 251 252 253 254
        }}
      where
        name          = availName sig_avail

    dfun_names = map getName sig_insts

    -- In general, for hsig files we can't assume that the implementing
    -- file actually implemented the instances (they may be reexported
Simon Peyton Jones's avatar
Simon Peyton Jones committed
255
    -- from elsewhere).  Where should we look for the instances?  We do
256 257 258 259 260 261 262 263 264 265
    -- the same as we would otherwise: consult the EPS.  This isn't
    -- perfect (we might conclude the module exports an instance
    -- when it doesn't, see #9422), but we will never refuse to compile
    -- something
    check_inst :: ClsInst -> TcM ()
    check_inst sig_inst
        = do eps <- getEps
             when (not (memberInstEnv (eps_inst_env eps) sig_inst)) $
               addErrTc (instMisMatch False sig_inst)

266 267 268 269 270
tcRnModuleTcRnM :: HscEnv
                -> HscSource
                -> HsParsedModule
                -> (Module, SrcSpan)
                -> TcRn TcGblEnv
271
-- Factored out separately from tcRnModule so that a Core plugin can
272
-- call the type checker directly
273
tcRnModuleTcRnM hsc_env hsc_src
274 275 276 277 278 279 280 281 282
                (HsParsedModule {
                   hpm_module =
                      (L loc (HsModule maybe_mod export_ies
                                       import_decls local_decls mod_deprec
                                       maybe_doc_hdr)),
                   hpm_src_files = src_files
                })
                (this_mod, prel_imp_loc)
 = setSrcSpan loc $
Simon Peyton Jones's avatar
Simon Peyton Jones committed
283 284
   do { let { dflags = hsc_dflags hsc_env
            ; explicit_mod_hdr = isJust maybe_mod } ;
285 286

        tcg_env <- tcRnSignature dflags hsc_src ;
Simon Peyton Jones's avatar
Simon Peyton Jones committed
287 288 289 290 291 292 293 294 295 296 297 298
        setGblEnv tcg_env $ do {

                -- Load the hi-boot interface for this module, if any
                -- We do this now so that the boot_names can be passed
                -- to tcTyAndClassDecls, because the boot_names are
                -- 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_info <- tcHiBootIface hsc_src this_mod ;
        setGblEnv (tcg_env { tcg_self_boot = boot_info }) $ do {
299 300

        -- Deal with imports; first add implicit prelude
301 302 303 304
        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
305
        whenWOptM Opt_WarnImplicitPrelude $
306 307
             when (notNull prel_imports) $ addWarn (implicitPreludeWarn) ;

dterei's avatar
dterei committed
308
        tcg_env <- {-# SCC "tcRnImports" #-}
309
                   tcRnImports hsc_env (prel_imports ++ import_decls) ;
310

Austin Seipp's avatar
Austin Seipp committed
311
          -- If the whole module is warned about or deprecated
312 313
          -- (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
314 315 316
        let { tcg_env1 = case mod_deprec of
                         Just (L _ txt) -> tcg_env { tcg_warns = WarnAll txt }
                         Nothing        -> tcg_env
317
            } ;
318

319
        setGblEnv tcg_env1 $ do {
dterei's avatar
dterei committed
320 321 322

                -- Rename and type check the declarations
        traceRn (text "rn1a") ;
323 324
        tcg_env <- if isHsBootOrSig hsc_src then
                        tcRnHsBootDecls hsc_src local_decls
dterei's avatar
dterei committed
325
                   else
dterei's avatar
dterei committed
326
                        {-# SCC "tcRnSrcDecls" #-}
Simon Peyton Jones's avatar
Simon Peyton Jones committed
327
                        tcRnSrcDecls explicit_mod_hdr export_ies local_decls ;
dterei's avatar
dterei committed
328 329 330
        setGblEnv tcg_env               $ do {

                -- Process the export list
331
        traceRn (text "rn4a: before exports");
Simon Peyton Jones's avatar
Simon Peyton Jones committed
332
        tcg_env <- rnExports explicit_mod_hdr export_ies tcg_env ;
dterei's avatar
dterei committed
333
        traceRn (text "rn4b: after exports") ;
334

335 336 337
                -- Check that main is exported (must be after rnExports)
        checkMainExported tcg_env ;

dterei's avatar
dterei committed
338 339
        -- Compare the hi-boot iface (if any) with the real thing
        -- Must be done after processing the exports
Simon Peyton Jones's avatar
Simon Peyton Jones committed
340
        tcg_env <- checkHiBootIface tcg_env boot_info ;
341

342 343 344 345 346 347 348 349 350 351 352 353 354 355 356
        -- Compare the hsig tcg_env with the real thing
        checkHsigIface hsc_env tcg_env ;

        -- Nub out type class instances now that we've checked them,
        -- if we're compiling an hsig with sig-of.
        -- See Note [Signature files and type class instances]
        tcg_env <- (case tcg_sig_of tcg_env of
            Just _ -> return tcg_env {
                        tcg_inst_env = emptyInstEnv,
                        tcg_fam_inst_env = emptyFamInstEnv,
                        tcg_insts = [],
                        tcg_fam_insts = []
                        }
            Nothing -> return tcg_env) ;

dterei's avatar
dterei committed
357
        -- The new type env is already available to stuff slurped from
dterei's avatar
dterei committed
358
        -- interface files, via TcEnv.updateGlobalTypeEnv
dterei's avatar
dterei committed
359 360
        -- 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
361
        -- which may be mentioned in imported unfoldings
362

dterei's avatar
dterei committed
363 364 365
                -- 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 }) ;
366

dterei's avatar
dterei committed
367 368
                -- Report unused names
        reportUnusedNames export_ies tcg_env ;
369

370 371 372 373
                -- add extra source files to tcg_dependent_files
        addDependentFiles src_files ;

                -- Dump output and return
dterei's avatar
dterei committed
374 375
        tcDump tcg_env ;
        return tcg_env
Simon Peyton Jones's avatar
Simon Peyton Jones committed
376
    }}}}}
377 378 379 380

implicitPreludeWarn :: SDoc
implicitPreludeWarn
  = ptext (sLit "Module `Prelude' implicitly imported")
381

Austin Seipp's avatar
Austin Seipp committed
382 383 384
{-
************************************************************************
*                                                                      *
dterei's avatar
dterei committed
385
                Import declarations
Austin Seipp's avatar
Austin Seipp committed
386 387 388
*                                                                      *
************************************************************************
-}
389

390 391
tcRnImports :: HscEnv -> [LImportDecl RdrName] -> TcM TcGblEnv
tcRnImports hsc_env import_decls
392
  = do  { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ;
dterei's avatar
dterei committed
393

394
        ; this_mod <- getModule
dterei's avatar
dterei committed
395
        ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
Austin Seipp's avatar
Austin Seipp committed
396
              ; dep_mods = imp_dep_mods imports
dterei's avatar
dterei committed
397 398 399 400

                -- 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
401 402 403 404
                -- get the instances from this module's hs-boot file.  This
                -- filtering also ensures that we don't see instances from
                -- modules batch (@--make@) compiled before this one, but
                -- which are not below this one.
dterei's avatar
dterei committed
405 406 407
              ; want_instances :: ModuleName -> Bool
              ; want_instances mod = mod `elemUFM` dep_mods
                                   && mod /= moduleName this_mod
dterei's avatar
dterei committed
408
              ; (home_insts, home_fam_insts) = hptInstances hsc_env
409
                                                            want_instances
dterei's avatar
dterei committed
410
              } ;
411

dterei's avatar
dterei committed
412
                -- Record boot-file info in the EPS, so that it's
dterei's avatar
dterei committed
413 414 415
                -- visible to loadHiBootInterface in tcRnSrcDecls,
                -- and any other incrementally-performed imports
        ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
416

dterei's avatar
dterei committed
417
                -- Update the gbl env
dterei's avatar
dterei committed
418 419
        ; updGblEnv ( \ gbl ->
            gbl {
420
              tcg_rdr_env      = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env,
dterei's avatar
dterei committed
421
              tcg_imports      = tcg_imports gbl `plusImportAvails` imports,
422
              tcg_rn_imports   = rn_imports,
dterei's avatar
dterei committed
423
              tcg_inst_env     = extendInstEnvList (tcg_inst_env gbl) home_insts,
dterei's avatar
dterei committed
424
              tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
425
                                                      home_fam_insts,
dterei's avatar
dterei committed
426 427 428 429 430
              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
431
                -- The error printing (if needed) takes advantage
dterei's avatar
dterei committed
432 433 434 435 436 437
                -- 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
438 439
                -- found.  But filter out a self hs-boot: these instances
                -- will be checked when we define them locally.
dterei's avatar
dterei committed
440
        ; loadModuleInterfaces (ptext (sLit "Loading orphan modules"))
441
                               (filter (/= this_mod) (imp_orphs imports))
442

Simon Marlow's avatar
Simon Marlow committed
443
                -- Check type-family consistency
dterei's avatar
dterei committed
444 445
        ; traceRn (text "rn1: checking family instance consistency")
        ; let { dir_imp_mods = moduleEnvKeys
dterei's avatar
dterei committed
446
                             . imp_mods
dterei's avatar
dterei committed
447 448
                             $ imports }
        ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ;
449

dterei's avatar
dterei committed
450
        ; getGblEnv } }
451

Austin Seipp's avatar
Austin Seipp committed
452 453 454
{-
************************************************************************
*                                                                      *
dterei's avatar
dterei committed
455
        Type-checking the top level of a module
Austin Seipp's avatar
Austin Seipp committed
456 457 458
*                                                                      *
************************************************************************
-}
459

Simon Peyton Jones's avatar
Simon Peyton Jones committed
460
tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all
461 462 463
             -> Maybe (Located [LIE RdrName])   -- Exports
             -> [LHsDecl RdrName]               -- Declarations
             -> TcM TcGblEnv
dterei's avatar
dterei committed
464 465
        -- Returns the variables free in the decls
        -- Reason: solely to report unused imports and bindings
Simon Peyton Jones's avatar
Simon Peyton Jones committed
466
tcRnSrcDecls explicit_mod_hdr exports decls
dterei's avatar
dterei committed
467
 = do {         -- Do all the declarations
Simon Peyton Jones's avatar
Simon Peyton Jones committed
468 469 470 471 472 473 474 475 476 477 478 479 480 481 482
        ((tcg_env, tcl_env), lie) <- captureConstraints $
              do { (tcg_env, tcl_env) <- tc_rn_src_decls decls ;
                 ; tcg_env <- setEnvs (tcg_env, tcl_env) $
                              checkMain explicit_mod_hdr
                 ; return (tcg_env, tcl_env) }
      ; setEnvs (tcg_env, tcl_env) $ do {

#ifdef GHCI
        -- Run all module finalizers
        let th_modfinalizers_var = tcg_th_modfinalizers tcg_env
      ; modfinalizers <- readTcRef th_modfinalizers_var
      ; writeTcRef th_modfinalizers_var []
      ; mapM_ runQuasi modfinalizers
#endif /* GHCI */

Facundo Domínguez's avatar
Facundo Domínguez committed
483
        -- wanted constraints from static forms
Simon Peyton Jones's avatar
Simon Peyton Jones committed
484
      ; stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef
485

dterei's avatar
dterei committed
486
             --         Finish simplifying class constraints
dterei's avatar
dterei committed
487 488
             --
             -- simplifyTop deals with constant or ambiguous InstIds.
dterei's avatar
dterei committed
489 490 491 492
             -- 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
493
             -- We do this after checkMain, so that we use the type info
dterei's avatar
dterei committed
494
             -- that checkMain adds
dterei's avatar
dterei committed
495
             --
dterei's avatar
dterei committed
496 497
             -- We do it with both global and local env in scope:
             --  * the global env exposes the instances to simplifyTop
dterei's avatar
dterei committed
498
             --  * the local env exposes the local Ids to simplifyTop,
dterei's avatar
dterei committed
499
             --    so that we get better error messages (monomorphism restriction)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
500 501 502
      ; new_ev_binds <- {-# SCC "simplifyTop" #-}
                        simplifyTop (andWC stWC lie)
      ; traceTc "Tc9" empty
503

Simon Peyton Jones's avatar
Simon Peyton Jones committed
504
      ; failIfErrsM     -- Don't zonk if there have been errors
dterei's avatar
dterei committed
505 506
                        -- It's a waste of time; and we may get debug warnings
                        -- about strangely-typed TyCons!
507

508 509
        -- Zonk the final code.  This must be done last.
        -- Even simplifyTop may do some unification.
510
        -- This pass also warns about missing type signatures
Simon Peyton Jones's avatar
Simon Peyton Jones committed
511
      ; let { TcGblEnv { tcg_type_env  = type_env,
512 513 514 515 516 517 518
                         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
519
            ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
520

Simon Peyton Jones's avatar
Simon Peyton Jones committed
521
      ; (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
522
            <- {-# SCC "zonkTopDecls" #-}
523 524
               zonkTopDecls all_ev_binds binds exports sig_ns rules vects
                            imp_specs fords ;
dterei's avatar
dterei committed
525

Simon Peyton Jones's avatar
Simon Peyton Jones committed
526
      ; let { final_type_env = extendTypeEnvWithIds type_env bind_ids
527 528 529
            ; tcg_env' = tcg_env { tcg_binds    = binds',
                                   tcg_ev_binds = ev_binds',
                                   tcg_imp_specs = imp_specs',
dterei's avatar
dterei committed
530 531
                                   tcg_rules    = rules',
                                   tcg_vects    = vects',
532 533
                                   tcg_fords    = fords' } } ;

Simon Peyton Jones's avatar
Simon Peyton Jones committed
534
      ; setGlobalTypeEnv tcg_env' final_type_env
Austin Seipp's avatar
Austin Seipp committed
535

536
   } }
537

Simon Peyton Jones's avatar
Simon Peyton Jones committed
538
tc_rn_src_decls :: [LHsDecl RdrName]
gmainland's avatar
gmainland committed
539
                -> TcM (TcGblEnv, TcLclEnv)
dterei's avatar
dterei committed
540
-- Loops around dealing with each top level inter-splice group
541
-- in turn, until it's dealt with the entire module
Simon Peyton Jones's avatar
Simon Peyton Jones committed
542
tc_rn_src_decls ds
543
 = {-# SCC "tc_rn_src_decls" #-}
gmainland's avatar
gmainland committed
544
   do { (first_group, group_tail) <- findSplice ds
dterei's avatar
dterei committed
545
                -- If ds is [] we get ([], Nothing)
dterei's avatar
dterei committed
546

dterei's avatar
dterei committed
547
        -- Deal with decls up to, but not including, the first splice
Simon Peyton Jones's avatar
Simon Peyton Jones committed
548
      ; (tcg_env, rn_decls) <- rnTopSrcDecls first_group
dterei's avatar
dterei committed
549
                -- rnTopSrcDecls fails if there are any errors
dterei's avatar
dterei committed
550

551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567
#ifdef GHCI
        -- Get TH-generated top-level declarations and make sure they don't
        -- contain any splices since we don't handle that at the moment
      ; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv
      ; th_ds <- readTcRef th_topdecls_var
      ; writeTcRef th_topdecls_var []

      ; (tcg_env, rn_decls) <-
            if null th_ds
            then return (tcg_env, rn_decls)
            else do { (th_group, th_group_tail) <- findSplice th_ds
                    ; case th_group_tail of
                        { Nothing -> return () ;
                        ; Just (SpliceDecl (L loc _) _, _)
                            -> setSrcSpan loc $
                               addErr (ptext (sLit "Declaration splices are not permitted inside top-level declarations added with addTopDecls"))
                        } ;
Austin Seipp's avatar
Austin Seipp committed
568

569 570
                    -- Rename TH-generated top-level declarations
                    ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env $
Simon Peyton Jones's avatar
Simon Peyton Jones committed
571
                      rnTopSrcDecls th_group
572 573

                    -- Dump generated top-level declarations
574
                    ; let msg = "top-level declarations added with addTopDecls"
575 576 577 578
                    ; traceSplice $ SpliceInfo { spliceDescription = msg
                                               , spliceIsDecl    = True
                                               , spliceSource    = Nothing
                                               , spliceGenerated = ppr th_rn_decls }
579 580 581 582 583 584

                    ; return (tcg_env, appendGroups rn_decls th_rn_decls)
                    }
#endif /* GHCI */

      -- Type check all declarations
gmainland's avatar
gmainland committed
585
      ; (tcg_env, tcl_env) <- setGblEnv tcg_env $
Simon Peyton Jones's avatar
Simon Peyton Jones committed
586
                              tcTopSrcDecls rn_decls
587

dterei's avatar
dterei committed
588
        -- If there is no splice, we're nearly done
gmainland's avatar
gmainland committed
589 590
      ; setEnvs (tcg_env, tcl_env) $
        case group_tail of
Simon Peyton Jones's avatar
Simon Peyton Jones committed
591
          { Nothing -> return (tcg_env, tcl_env)
592 593

#ifndef GHCI
gmainland's avatar
gmainland committed
594 595 596 597
            -- There shouldn't be a splice
          ; Just (SpliceDecl {}, _) ->
            failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
          }
598
#else
gmainland's avatar
gmainland committed
599 600 601
            -- If there's a splice, we must carry on
          ; Just (SpliceDecl (L _ splice) _, rest_ds) ->
            do { -- Rename the splice expression, and get its supporting decls
602
                 (spliced_decls, splice_fvs) <- checkNoErrs (rnTopSpliceDecls splice)
gmainland's avatar
gmainland committed
603 604 605

                 -- Glue them on the front of the remaining decls and loop
               ; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
Simon Peyton Jones's avatar
Simon Peyton Jones committed
606
                 tc_rn_src_decls (spliced_decls ++ rest_ds)
gmainland's avatar
gmainland committed
607 608
               }
          }
609
#endif /* GHCI */
gmainland's avatar
gmainland committed
610
      }
611

Austin Seipp's avatar
Austin Seipp committed
612 613 614
{-
************************************************************************
*                                                                      *
dterei's avatar
dterei committed
615 616
        Compiling hs-boot source files, and
        comparing the hi-boot interface with the real thing
Austin Seipp's avatar
Austin Seipp committed
617 618 619
*                                                                      *
************************************************************************
-}
620

621 622
tcRnHsBootDecls :: HscSource -> [LHsDecl RdrName] -> TcM TcGblEnv
tcRnHsBootDecls hsc_src decls
623
   = do { (first_group, group_tail) <- findSplice decls
624

dterei's avatar
dterei committed
625
                -- Rename the declarations
dterei's avatar
dterei committed
626 627
        ; (tcg_env, HsGroup {
                   hs_tyclds = tycl_decls,
dterei's avatar
dterei committed
628 629 630
                   hs_instds = inst_decls,
                   hs_derivds = deriv_decls,
                   hs_fords  = for_decls,
dterei's avatar
dterei committed
631 632 633
                   hs_defds  = def_decls,
                   hs_ruleds = rule_decls,
                   hs_vects  = vect_decls,
dterei's avatar
dterei committed
634
                   hs_annds  = _,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
635
                   hs_valds  = val_binds }) <- rnTopSrcDecls first_group
636 637
        -- 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
638 639 640 641 642
        ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {


                -- Check for illegal declarations
        ; case group_tail of
643
             Just (SpliceDecl d _, _) -> badBootDecl hsc_src "splice" d
dterei's avatar
dterei committed
644
             Nothing                  -> return ()
645 646 647 648
        ; mapM_ (badBootDecl hsc_src "foreign") for_decls
        ; mapM_ (badBootDecl hsc_src "default") def_decls
        ; mapM_ (badBootDecl hsc_src "rule")    rule_decls
        ; mapM_ (badBootDecl hsc_src "vect")    vect_decls
dterei's avatar
dterei committed
649

650
                -- Typecheck type/class/isntance decls
651
        ; traceTc "Tc2 (boot)" empty
dterei's avatar
dterei committed
652
        ; (tcg_env, inst_infos, _deriv_binds)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
653
             <- tcTyClsInstDecls tycl_decls inst_decls deriv_decls
dterei's avatar
dterei committed
654 655 656
        ; setGblEnv tcg_env     $ do {

                -- Typecheck value declarations
dterei's avatar
dterei committed
657
        ; traceTc "Tc5" empty
dterei's avatar
dterei committed
658 659 660 661 662
        ; val_ids <- tcHsBootSigs val_binds

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

dterei's avatar
dterei committed
665 666
                -- Make the final type-env
                -- Include the dfun_ids so that their type sigs
dterei's avatar
dterei committed
667
                -- are written into the interface file.
dterei's avatar
dterei committed
668 669
        ; let { type_env0 = tcg_type_env gbl_env
              ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
670 671 672 673
              -- Don't add the dictionaries for hsig, we don't actually want
              -- to /define/ the instance
              ; type_env2 | HsigFile <- hsc_src = type_env1
                          | otherwise = extendTypeEnvWithIds type_env1 dfun_ids
dterei's avatar
dterei committed
674 675 676 677
              ; dfun_ids = map iDFunId inst_infos
              }

        ; setGlobalTypeEnv gbl_env type_env2
678
   }}
679
   ; traceTc "boot" (ppr lie); return gbl_env }
680

681 682
badBootDecl :: HscSource -> String -> Located decl -> TcM ()
badBootDecl hsc_src what (L loc _)
dterei's avatar
dterei committed
683
  = addErrAt loc (char 'A' <+> text what
684 685 686 687 688 689
      <+> ptext (sLit "declaration is not (currently) allowed in a")
      <+> (case hsc_src of
            HsBootFile -> ptext (sLit "hs-boot")
            HsigFile -> ptext (sLit "hsig")
            _ -> panic "badBootDecl: should be an hsig or hs-boot file")
      <+> ptext (sLit "file"))
690

Austin Seipp's avatar
Austin Seipp committed
691
{-
692 693
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).
Austin Seipp's avatar
Austin Seipp committed
694
-}
695

Simon Peyton Jones's avatar
Simon Peyton Jones committed
696
checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv
697 698
-- Compare the hi-boot file for this module (if there is one)
-- with the type environment we've just come up with
699 700
-- In the common case where there is no hi-boot file, the list
-- of boot_names is empty.
701

Simon Peyton Jones's avatar
Simon Peyton Jones committed
702 703
checkHiBootIface tcg_env boot_info
  | NoSelfBoot <- boot_info  -- Common case
dterei's avatar
dterei committed
704
  = return tcg_env
705

Simon Peyton Jones's avatar
Simon Peyton Jones committed
706 707 708 709 710 711 712 713
  | HsBootFile <- tcg_src tcg_env   -- Current module is already a hs-boot file!
  = return tcg_env

  | SelfBoot { sb_mds = boot_details } <- boot_info
  , TcGblEnv { tcg_binds    = binds
             , tcg_insts    = local_insts
             , tcg_type_env = local_type_env
             , tcg_exports  = local_exports } <- tcg_env
714 715 716
  = do  { dfun_prs <- checkHiBootIface' local_insts local_type_env
                                        local_exports boot_details
        ; let boot_dfuns = map fst dfun_prs
717 718 719 720 721 722 723 724 725 726 727
              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 }

        ; setGlobalTypeEnv tcg_env' type_env' }
             -- Update the global type env *including* the knot-tied one
             -- 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

Simon Peyton Jones's avatar
Simon Peyton Jones committed
728 729
  | otherwise = panic "checkHiBootIface: unreachable code"

730
checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo]
731
                  -> ModDetails -> TcM [(Id, Id)]
732 733
-- Variant which doesn't require a full TcGblEnv; you could get the
-- local components from another ModDetails.
734
--
Gabor Greif's avatar
Gabor Greif committed
735
-- We return a list of "impedance-matching" bindings for the dfuns
736 737 738 739
-- defined in the hs-boot file, such as
--           $fxEqT = $fEqT
-- We need these because the module and hi-boot file might differ in
-- the name it chose for the dfun.
740 741 742 743 744

checkHiBootIface'
        local_insts local_type_env local_exports
        (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
                      md_types = boot_type_env, md_exports = boot_exports })
dterei's avatar
dterei committed
745
  = do  { traceTc "checkHiBootIface" $ vcat
746
             [ ppr boot_type_env, ppr boot_insts, ppr boot_exports]
747

dterei's avatar
dterei committed
748 749
                -- Check the exports of the boot module, one by one
        ; mapM_ check_export boot_exports
750

dterei's avatar
dterei committed
751 752 753 754
                -- Check for no family instances
        ; unless (null boot_fam_insts) $
            panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
                   "instances in boot files yet...")
755
            -- FIXME: Why?  The actual comparison is not hard, but what would
dterei's avatar
dterei committed
756 757
            --        be the equivalent to the dfun bindings returned for class
            --        instances?  We can't easily equate tycons...
758

dterei's avatar
dterei committed
759
                -- Check instance declarations
Gabor Greif's avatar
Gabor Greif committed
760
                -- and generate an impedance-matching binding
dterei's avatar
dterei committed
761
        ; mb_dfun_prs <- mapM check_inst boot_insts
762

763
        ; failIfErrsM
764

765
        ; return (catMaybes mb_dfun_prs) }
766

767
  where
dterei's avatar
dterei committed
768
    check_export boot_avail     -- boot_avail is exported by the boot iface
dterei's avatar
dterei committed
769
      | name `elem` dfun_names = return ()
dterei's avatar
dterei committed
770 771 772
      | 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)
773

dterei's avatar
dterei committed
774
        -- Check that the actual module exports the same thing
775
      | not (null missing_names)
dterei's avatar
dterei committed
776
      = addErrAt (nameSrcSpan (head missing_names))
777
                 (missingBootThing True (head missing_names) "exported by")
778

dterei's avatar
dterei committed
779 780
        -- 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)
781
      | isNothing mb_boot_thing = return ()
782

dterei's avatar
dterei committed
783
        -- Check that the actual module also defines the thing, and
dterei's avatar
dterei committed
784
        -- then compare the definitions
785 786
      | Just real_thing <- lookupTypeEnv local_type_env name,
        Just boot_thing <- mb_boot_thing
787
      = checkBootDeclM True boot_thing real_thing
788

789
      | otherwise
790
      = addErrTc (missingBootThing True name "defined in")
791
      where
dterei's avatar
dterei committed
792 793 794 795 796
        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
797

798 799
    dfun_names = map getName boot_insts

800 801
    local_export_env :: NameEnv AvailInfo
    local_export_env = availsToNameEnv local_exports
802

803
    check_inst :: ClsInst -> TcM (Maybe (Id, Id))
dterei's avatar
dterei committed
804
        -- Returns a pair of the boot dfun in terms of the equivalent real dfun
805
    check_inst boot_inst
dterei's avatar
dterei committed
806
        = case [dfun | inst <- local_insts,
dterei's avatar
dterei committed
807
                       let dfun = instanceDFunId inst,
808 809 810 811 812 813
                       idType dfun `eqType` boot_dfun_ty ] of
            [] -> do { traceTc "check_inst" $ vcat
                          [ text "local_insts"  <+> vcat (map (ppr . idType . instanceDFunId) local_insts)
                          , text "boot_inst"    <+> ppr boot_inst
                          , text "boot_dfun_ty" <+> ppr boot_dfun_ty
                          ]
814
                     ; addErrTc (instMisMatch True boot_inst); return Nothing }
dterei's avatar
dterei committed
815
            (dfun:_) -> return (Just (local_boot_dfun, dfun))
816 817 818 819 820 821 822
                     where
                        local_boot_dfun = Id.mkExportedLocalId VanillaId boot_dfun_name (idType dfun)
                           -- Name from the /boot-file/ ClsInst, but type from the dfun
                           -- defined in /this module/.  That ensures that the TyCon etc
                           -- inside the type are the ones defined in this module, not
                           -- the ones gotten from the hi-boot file, which may have
                           -- a lot less info (Trac #T8743, comment:10).
dterei's avatar
dterei committed
823
        where
824 825 826
          boot_dfun      = instanceDFunId boot_inst
          boot_dfun_ty   = idType boot_dfun
          boot_dfun_name = idName boot_dfun
827

828 829 830 831 832 833 834
-- 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.

835 836 837 838 839 840 841 842 843 844 845 846 847 848
-- | Compares two things for equivalence between boot-file and normal code,
-- reporting an error if they don't match up.
checkBootDeclM :: Bool  -- ^ True <=> an hs-boot file (could also be a sig)
               -> TyThing -> TyThing -> TcM ()
checkBootDeclM is_boot boot_thing real_thing
  = whenIsJust (checkBootDecl boot_thing real_thing) $ \ err ->
    addErrAt (nameSrcSpan (getName boot_thing))
             (bootMisMatch is_boot err real_thing boot_thing)

-- | Compares the two things for equivalence between boot-file and normal
-- code. Returns @Nothing@ on success or @Just "some helpful info for user"@
-- failure. If the difference will be apparent to the user, @Just empty@ is
-- perfectly suitable.
checkBootDecl :: TyThing -> TyThing -> Maybe SDoc
849 850

checkBootDecl (AnId id1) (AnId id2)
dterei's avatar
dterei committed
851
  = ASSERT(id1 == id2)
852 853
    check (idType id1 `eqType` idType id2)
          (text "The two types are different")
854 855

checkBootDecl (ATyCon tc1) (ATyCon tc2)
856 857
  = checkBootTyCon tc1 tc2

Gergő Érdi's avatar
Gergő Érdi committed
858
checkBootDecl (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _))
batterseapower's avatar
batterseapower committed
859 860
  = pprPanic "checkBootDecl" (ppr dc1)

861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882
checkBootDecl _ _ = Just empty -- probably shouldn't happen

-- | Combines two potential error messages
andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc
Nothing `andThenCheck` msg     = msg
msg     `andThenCheck` Nothing = msg
Just d1 `andThenCheck` Just d2 = Just (d1 $$ d2)
infixr 0 `andThenCheck`

-- | If the test in the first parameter is True, succeed with @Nothing@;
-- otherwise, return the provided check
checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc
checkUnless True  _ = Nothing
checkUnless False k = k

-- | Run the check provided for every pair of elements in the lists.
-- The provided SDoc should name the element type, in the