TcRnDriver.hs 123 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[TcRnDriver]{Typechecking a whole module}
6

7
https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/type-checker
Austin Seipp's avatar
Austin Seipp committed
8
-}
9

10
{-# LANGUAGE CPP #-}
Simon Marlow's avatar
Simon Marlow committed
11
{-# LANGUAGE BangPatterns #-}
12 13
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NondecreasingIndentation #-}
Edward Z. Yang's avatar
Edward Z. Yang committed
14 15
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
16
{-# LANGUAGE TypeFamilies #-}
17
{-# LANGUAGE FlexibleContexts #-}
18
{-# LANGUAGE ViewPatterns #-}
19

20
module TcRnDriver (
21
        tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType,
dterei's avatar
dterei committed
22 23 24 25
        tcRnImportDecls,
        tcRnLookupRdrName,
        getModuleInterface,
        tcRnDeclsi,
dterei's avatar
dterei committed
26
        isGHCiMonad,
27
        runTcInteractive,    -- Used by GHC API clients (#8878)
dterei's avatar
dterei committed
28 29
        tcRnLookupName,
        tcRnGetInfo,
30
        tcRnModule, tcRnModuleTcRnM,
Adam Gundry's avatar
Adam Gundry committed
31
        tcTopSrcDecls,
Edward Z. Yang's avatar
Edward Z. Yang committed
32 33 34 35 36 37 38 39 40
        rnTopSrcDecls,
        checkBootDecl, checkHiBootIface',
        findExtraSigImports,
        implicitRequirements,
        checkUnitId,
        mergeSignatures,
        tcRnMergeSignatures,
        instantiateSignature,
        tcRnInstantiateSignature,
41
        loadUnqualIfaces,
Edward Z. Yang's avatar
Edward Z. Yang committed
42 43 44 45
        -- More private...
        badReexportedBootThing,
        checkBootDeclM,
        missingBootThing,
46
        getRenamedStuff, RenamedStuff
47 48
    ) where

49 50
import GhcPrelude

51
import {-# SOURCE #-} TcSplice ( finishTH, runRemoteModFinalizers )
52
import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )
53 54
import IfaceEnv( externaliseName )
import TcHsType
55
import TcValidity( checkValidType )
56
import TcMatches
57
import Inst( deeplyInstantiate )
58
import TcUnify( checkConstraints )
59 60
import RnTypes
import RnExpr
61 62
import RnUtils ( HsDocContext(..) )
import RnFixity ( lookupFixityRn )
63 64
import MkId
import TysWiredIn ( unitTy, mkListTy )
65
import Plugins
66
import DynFlags
Sylvain Henry's avatar
Sylvain Henry committed
67
import GHC.Hs
68 69
import IfaceSyn ( ShowSub(..), showToHeader )
import IfaceType( ShowForAllFlag(..) )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
70
import PatSyn( pprPatSynType )
71
import PrelNames
72
import PrelInfo
73 74 75
import RdrName
import TcHsSyn
import TcExpr
76
import TcRnMonad
77
import TcRnExports
78
import TcEvidence
79
import qualified BooleanFormula as BF
80
import PprTyThing( pprTyThingInContext )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
81
import CoreFVs( orphNamesOfFamInst )
82
import FamInst
83
import InstEnv
84 85
import FamInstEnv( FamInst, pprFamInst, famInstsRepTyCons
                 , famInstEnvElts, extendFamInstEnvList, normaliseType )
86
import TcAnnotations
87
import TcBinds
88
import MkIface          ( coAxiomToIfaceDecl )
89
import HeaderInfo       ( mkPrelImports )
90 91 92 93 94 95
import TcDefaults
import TcEnv
import TcRules
import TcForeign
import TcInstDcls
import TcIface
96
import TcMType
97
import TcType
98 99
import TcSimplify
import TcTyClsDecls
100
import TcTypeable ( mkTypeableBinds )
Edward Z. Yang's avatar
Edward Z. Yang committed
101
import TcBackpack
102 103 104 105 106 107
import LoadIface
import RnNames
import RnEnv
import RnSource
import ErrUtils
import Id
108
import IdInfo( IdDetails(..) )
109
import VarEnv
Simon Marlow's avatar
Simon Marlow committed
110
import Module
111
import UniqFM
112
import Name
113
import NameEnv
114
import NameSet
115
import Avail
116 117 118
import TyCon
import SrcLoc
import HscTypes
119
import ListSetOps
120
import Outputable
cactus's avatar
cactus committed
121
import ConLike
122 123 124
import DataCon
import Type
import Class
125
import BasicTypes hiding( SuccessFlag(..) )
126
import CoAxiom
127
import Annotations
128
import Data.List ( sortBy, sort )
129
import Data.Ord
130
import FastString
131
import Maybes
132 133
import Util
import Bag
134
import Inst (tcGetInsts)
135
import qualified GHC.LanguageExtensions as LangExt
136
import Data.Data ( Data )
Sylvain Henry's avatar
Sylvain Henry committed
137
import GHC.Hs.Dump
138
import qualified Data.Set as S
139

Simon Marlow's avatar
Simon Marlow committed
140
import Control.DeepSeq
141
import Control.Monad
142

143 144 145
import TcHoleFitTypes ( HoleFitPluginR (..) )


146
#include "HsVersions.h"
147

Austin Seipp's avatar
Austin Seipp committed
148 149 150
{-
************************************************************************
*                                                                      *
dterei's avatar
dterei committed
151
        Typecheck and rename a module
Austin Seipp's avatar
Austin Seipp committed
152 153 154
*                                                                      *
************************************************************************
-}
155

156
-- | Top level entry point for typechecker and renamer
dterei's avatar
dterei committed
157
tcRnModule :: HscEnv
158
           -> ModSummary
dterei's avatar
dterei committed
159
           -> Bool              -- True <=> save renamed syntax
160
           -> HsParsedModule
dterei's avatar
dterei committed
161
           -> IO (Messages, Maybe TcGblEnv)
162

163
tcRnModule hsc_env mod_sum save_rn_syntax
164
   parsedModule@HsParsedModule {hpm_module= (dL->L loc this_module)}
165
 | RealSrcSpan real_loc <- loc
166 167 168 169
 = withTiming (pure dflags)
              (text "Renamer/typechecker"<+>brackets (ppr this_mod))
              (const ()) $
   initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $
170
          withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $
171

172
          tcRnModuleTcRnM hsc_env mod_sum parsedModule pair
dterei's avatar
dterei committed
173

174 175 176 177
  | otherwise
  = return ((emptyBag, unitBag err_msg), Nothing)

  where
178
    hsc_src = ms_hsc_src mod_sum
179
    dflags = hsc_dflags hsc_env
180 181 182 183 184 185 186
    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,_)
187
      | Just (dL->L mod_loc mod) <- hsmodName this_module
188 189 190 191
      = (mkModule this_pkg mod, mod_loc)

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

193

194 195


196
tcRnModuleTcRnM :: HscEnv
197
                -> ModSummary
198 199 200
                -> HsParsedModule
                -> (Module, SrcSpan)
                -> TcRn TcGblEnv
201
-- Factored out separately from tcRnModule so that a Core plugin can
202
-- call the type checker directly
203
tcRnModuleTcRnM hsc_env mod_sum
204 205
                (HsParsedModule {
                   hpm_module =
206
                      (dL->L loc (HsModule maybe_mod export_ies
207 208 209 210 211 212
                                       import_decls local_decls mod_deprec
                                       maybe_doc_hdr)),
                   hpm_src_files = src_files
                })
                (this_mod, prel_imp_loc)
 = setSrcSpan loc $
213
   do { let { explicit_mod_hdr = isJust maybe_mod
214 215 216 217 218 219 220 221 222 223 224 225 226 227 228
            ; hsc_src          = ms_hsc_src mod_sum }
      ; -- 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
        tcg_env <- getGblEnv
      ; boot_info <- tcHiBootIface hsc_src this_mod
      ; setGblEnv (tcg_env { tcg_self_boot = boot_info })
        $ do
        { -- Deal with imports; first add implicit prelude
          implicit_prelude <- xoptM LangExt.ImplicitPrelude
        ; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc
                               implicit_prelude import_decls }

        ; whenWOptM Opt_WarnImplicitPrelude $
229
             when (notNull prel_imports) $
230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253
                addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn)

        ; -- TODO This is a little skeevy; maybe handle a bit more directly
          let { simplifyImport (dL->L _ idecl) =
                  ( fmap sl_fs (ideclPkgQual idecl) , ideclName idecl)
              }
        ; raw_sig_imports <- liftIO
                             $ findExtraSigImports hsc_env hsc_src
                                 (moduleName this_mod)
        ; raw_req_imports <- liftIO
                             $ implicitRequirements hsc_env
                                (map simplifyImport (prel_imports
                                                     ++ import_decls))
        ; let { mkImport (Nothing, dL->L _ mod_name) = noLoc
                $ (simpleImportDecl mod_name)
                  { ideclHiding = Just (False, noLoc [])}
              ; mkImport _ = panic "mkImport" }
        ; let { all_imports = prel_imports ++ import_decls
                       ++ map mkImport (raw_sig_imports ++ raw_req_imports) }
        ; -- OK now finally rename the imports
          tcg_env <- {-# SCC "tcRnImports" #-}
                     tcRnImports hsc_env all_imports

        ; -- If the whole module is warned about or deprecated
254
          -- (via mod_deprec) record that in tcg_warns. If we do thereby add
Gabor Greif's avatar
Gabor Greif committed
255
          -- a WarnAll, it will override any subsequent deprecations added to tcg_warns
256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273
          let { tcg_env1 = case mod_deprec of
                             Just (dL->L _ txt) ->
                               tcg_env {tcg_warns = WarnAll txt}
                             Nothing            -> tcg_env
              }
        ; setGblEnv tcg_env1
          $ do { -- Rename and type check the declarations
                 traceRn "rn1a" empty
               ; tcg_env <- if isHsBootOrSig hsc_src
                            then tcRnHsBootDecls hsc_src local_decls
                            else {-# SCC "tcRnSrcDecls" #-}
                                 tcRnSrcDecls explicit_mod_hdr local_decls
               ; setGblEnv tcg_env
                 $ do { -- Process the export list
                        traceRn "rn4a: before exports" empty
                      ; tcg_env <- tcRnExports explicit_mod_hdr export_ies
                                     tcg_env
                      ; traceRn "rn4b: after exports" empty
274 275 276 277
                      ; -- When a module header is specified,
                        -- check that the main module exports a main function.
                        -- (must be after tcRnExports)
                        when explicit_mod_hdr $ checkMainExported tcg_env
278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306
                      ; -- Compare hi-boot iface (if any) with the real thing
                        -- Must be done after processing the exports
                        tcg_env <- checkHiBootIface tcg_env boot_info
                      ; -- The new type env is already available to stuff
                        -- slurped from interface files, via
                        -- TcEnv.setGlobalTypeEnv. It's important that this
                        -- includes the stuff in checkHiBootIface,
                        -- because the latter might add new bindings for
                        -- boot_dfuns, which may be mentioned in imported
                        -- unfoldings.

                        -- 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 })
                      ; -- Report unused names
                        -- Do this /after/ typeinference, so that when reporting
                        -- a function with no type signature we can give the
                        -- inferred type
                        reportUnusedNames export_ies tcg_env
                      ; -- add extra source files to tcg_dependent_files
                        addDependentFiles src_files
                      ; tcg_env <- runTypecheckerPlugin mod_sum hsc_env tcg_env
                      ; -- Dump output and return
                        tcDump tcg_env
                      ; return tcg_env }
               }
        }
      }
307 308 309

implicitPreludeWarn :: SDoc
implicitPreludeWarn
310
  = text "Module `Prelude' implicitly imported"
311

Austin Seipp's avatar
Austin Seipp committed
312 313 314
{-
************************************************************************
*                                                                      *
dterei's avatar
dterei committed
315
                Import declarations
Austin Seipp's avatar
Austin Seipp committed
316 317 318
*                                                                      *
************************************************************************
-}
319

320
tcRnImports :: HscEnv -> [LImportDecl GhcPs] -> TcM TcGblEnv
321
tcRnImports hsc_env import_decls
322
  = do  { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ;
dterei's avatar
dterei committed
323

324
        ; this_mod <- getModule
325
        ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
Austin Seipp's avatar
Austin Seipp committed
326
              ; dep_mods = imp_dep_mods imports
dterei's avatar
dterei committed
327 328 329 330

                -- 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
331 332 333 334
                -- 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
335
              ; want_instances :: ModuleName -> Bool
336
              ; want_instances mod = mod `elemUFM` dep_mods
dterei's avatar
dterei committed
337
                                   && mod /= moduleName this_mod
dterei's avatar
dterei committed
338
              ; (home_insts, home_fam_insts) = hptInstances hsc_env
339
                                                            want_instances
dterei's avatar
dterei committed
340
              } ;
341

dterei's avatar
dterei committed
342
                -- Record boot-file info in the EPS, so that it's
dterei's avatar
dterei committed
343 344
                -- visible to loadHiBootInterface in tcRnSrcDecls,
                -- and any other incrementally-performed imports
345
        ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
346

dterei's avatar
dterei committed
347
                -- Update the gbl env
dterei's avatar
dterei committed
348 349
        ; updGblEnv ( \ gbl ->
            gbl {
350
              tcg_rdr_env      = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env,
dterei's avatar
dterei committed
351
              tcg_imports      = tcg_imports gbl `plusImportAvails` imports,
352
              tcg_rn_imports   = rn_imports,
dterei's avatar
dterei committed
353
              tcg_inst_env     = extendInstEnvList (tcg_inst_env gbl) home_insts,
dterei's avatar
dterei committed
354
              tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
355
                                                      home_fam_insts,
dterei's avatar
dterei committed
356 357 358
              tcg_hpc          = hpc_info
            }) $ do {

359
        ; traceRn "rn1" (ppr (imp_dep_mods imports))
dterei's avatar
dterei committed
360
                -- Fail if there are any errors so far
dterei's avatar
dterei committed
361
                -- The error printing (if needed) takes advantage
dterei's avatar
dterei committed
362 363 364 365
                -- of the tcg_env we have now set
--      ; traceIf (text "rdr_env: " <+> ppr rdr_env)
        ; failIfErrsM

366 367 368 369 370 371 372 373 374
                -- Load any orphan-module (including orphan family
                -- instance-module) interfaces, so that their rules and
                -- instance decls will be found.  But filter out a
                -- self hs-boot: these instances will be checked when
                -- we define them locally.
                -- (We don't need to load non-orphan family instance
                -- modules until we either try to use the instances they
                -- define, or define our own family instances, at which
                -- point we need to check them for consistency.)
375
        ; loadModuleInterfaces (text "Loading orphan modules")
376
                               (filter (/= this_mod) (imp_orphs imports))
377

378 379
                -- Check type-family consistency between imports.
                -- See Note [The type family instance consistency story]
380
        ; traceRn "rn1: checking family instance consistency {" empty
dterei's avatar
dterei committed
381
        ; let { dir_imp_mods = moduleEnvKeys
dterei's avatar
dterei committed
382
                             . imp_mods
dterei's avatar
dterei committed
383
                             $ imports }
384
        ; checkFamInstConsistency dir_imp_mods
385
        ; traceRn "rn1: } checking family instance consistency" empty
386

387
        ; getGblEnv } }
388

Austin Seipp's avatar
Austin Seipp committed
389 390 391
{-
************************************************************************
*                                                                      *
dterei's avatar
dterei committed
392
        Type-checking the top level of a module
Austin Seipp's avatar
Austin Seipp committed
393 394 395
*                                                                      *
************************************************************************
-}
396

Simon Peyton Jones's avatar
Simon Peyton Jones committed
397
tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all
398
             -> [LHsDecl GhcPs]               -- Declarations
399
             -> TcM TcGblEnv
400
tcRnSrcDecls explicit_mod_hdr decls
401
 = do { -- Do all the declarations
402
      ; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls
403

404 405
        -- Check for the 'main' declaration
        -- Must do this inside the captureTopConstraints
406
        -- NB: always set envs *before* captureTopConstraints
407 408 409
      ; (tcg_env, lie_main) <- setEnvs (tcg_env, tcl_env) $
                               captureTopConstraints $
                               checkMain explicit_mod_hdr
Simon Peyton Jones's avatar
Simon Peyton Jones committed
410

411
      ; setEnvs (tcg_env, tcl_env) $ do {
412

413
             --         Simplify constraints
dterei's avatar
dterei committed
414
             --
dterei's avatar
dterei committed
415
             -- We do this after checkMain, so that we use the type info
dterei's avatar
dterei committed
416
             -- that checkMain adds
dterei's avatar
dterei committed
417
             --
dterei's avatar
dterei committed
418 419
             -- We do it with both global and local env in scope:
             --  * the global env exposes the instances to simplifyTop
dterei's avatar
dterei committed
420
             --  * the local env exposes the local Ids to simplifyTop,
dterei's avatar
dterei committed
421
             --    so that we get better error messages (monomorphism restriction)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
422
      ; new_ev_binds <- {-# SCC "simplifyTop" #-}
423
                        simplifyTop (lie `andWC` lie_main)
424

425 426 427
        -- Emit Typeable bindings
      ; tcg_env <- mkTypeableBinds

428

Simon Peyton Jones's avatar
Simon Peyton Jones committed
429
      ; traceTc "Tc9" empty
430

Simon Peyton Jones's avatar
Simon Peyton Jones committed
431
      ; failIfErrsM     -- Don't zonk if there have been errors
dterei's avatar
dterei committed
432 433
                        -- It's a waste of time; and we may get debug warnings
                        -- about strangely-typed TyCons!
Matthew Pickering's avatar
Matthew Pickering committed
434
      ; traceTc "Tc10" empty
435

436 437
        -- Zonk the final code.  This must be done last.
        -- Even simplifyTop may do some unification.
438
        -- This pass also warns about missing type signatures
439
      ; (bind_env, ev_binds', binds', fords', imp_specs', rules')
440 441 442 443 444 445 446 447 448
            <- zonkTcGblEnv new_ev_binds tcg_env

        -- Finalizers must run after constraints are simplified, or some types
        -- might not be complete when using reify (see #12777).
        -- and also after we zonk the first time because we run typed splices
        -- in the zonker which gives rise to the finalisers.
      ; (tcg_env_mf, _) <- setGblEnv (clearTcGblEnv tcg_env)
                                     run_th_modfinalizers
      ; finishTH
Matthew Pickering's avatar
Matthew Pickering committed
449
      ; traceTc "Tc11" empty
dterei's avatar
dterei committed
450

451 452 453 454 455 456 457 458 459 460 461 462 463 464 465
      ; -- zonk the new bindings arising from running the finalisers.
        -- This won't give rise to any more finalisers as you can't nest
        -- finalisers inside finalisers.
      ; (bind_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf)
            <- zonkTcGblEnv emptyBag tcg_env_mf


      ; let { final_type_env = plusTypeEnv (tcg_type_env tcg_env)
                                (plusTypeEnv bind_env_mf bind_env)
            ; tcg_env' = tcg_env_mf
                          { tcg_binds    = binds' `unionBags` binds_mf,
                            tcg_ev_binds = ev_binds' `unionBags` ev_binds_mf ,
                            tcg_imp_specs = imp_specs' ++ imp_specs_mf ,
                            tcg_rules    = rules' ++ rules_mf ,
                            tcg_fords    = fords' ++ fords_mf } } ;
466

Simon Peyton Jones's avatar
Simon Peyton Jones committed
467
      ; setGlobalTypeEnv tcg_env' final_type_env
Austin Seipp's avatar
Austin Seipp committed
468

469
   } }
470

471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495
zonkTcGblEnv :: Bag EvBind -> TcGblEnv
             -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc,
                       [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc])
zonkTcGblEnv new_ev_binds tcg_env =
  let TcGblEnv {   tcg_binds     = binds,
                   tcg_ev_binds  = cur_ev_binds,
                   tcg_imp_specs = imp_specs,
                   tcg_rules     = rules,
                   tcg_fords     = fords } = tcg_env

      all_ev_binds = cur_ev_binds `unionBags` new_ev_binds

  in {-# SCC "zonkTopDecls" #-}
      zonkTopDecls all_ev_binds binds rules imp_specs fords


-- | Remove accumulated bindings, rules and so on from TcGblEnv
clearTcGblEnv :: TcGblEnv -> TcGblEnv
clearTcGblEnv tcg_env
  = tcg_env { tcg_binds    = emptyBag,
              tcg_ev_binds = emptyBag ,
              tcg_imp_specs = [],
              tcg_rules    = [],
              tcg_fords    = [] }

496 497 498 499 500 501 502 503 504 505
-- | Runs TH finalizers and renames and typechecks the top-level declarations
-- that they could introduce.
run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv)
run_th_modfinalizers = do
  th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
  th_modfinalizers <- readTcRef th_modfinalizers_var
  if null th_modfinalizers
  then getEnvs
  else do
    writeTcRef th_modfinalizers_var []
506 507 508
    let run_finalizer (lcl_env, f) =
            setLclEnv lcl_env (runRemoteModFinalizers f)

509 510 511
    (_, lie_th) <- captureTopConstraints $
                   mapM_ run_finalizer th_modfinalizers

512 513 514
      -- Finalizers can add top-level declarations with addTopDecls, so
      -- we have to run tc_rn_src_decls to get them
    (tcg_env, tcl_env, lie_top_decls) <- tc_rn_src_decls []
515

516
    setEnvs (tcg_env, tcl_env) $ do
517 518 519 520
      -- Subsequent rounds of finalizers run after any new constraints are
      -- simplified, or some types might not be complete when using reify
      -- (see #12777).
      new_ev_binds <- {-# SCC "simplifyTop2" #-}
521
                      simplifyTop (lie_th `andWC` lie_top_decls)
522
      addTopEvBinds new_ev_binds run_th_modfinalizers
523
        -- addTopDecls can add declarations which add new finalizers.
524

525
tc_rn_src_decls :: [LHsDecl GhcPs]
526
                -> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
dterei's avatar
dterei committed
527
-- Loops around dealing with each top level inter-splice group
528
-- in turn, until it's dealt with the entire module
529
-- Never emits constraints; calls captureTopConstraints internally
Simon Peyton Jones's avatar
Simon Peyton Jones committed
530
tc_rn_src_decls ds
531
 = {-# SCC "tc_rn_src_decls" #-}
gmainland's avatar
gmainland committed
532
   do { (first_group, group_tail) <- findSplice ds
dterei's avatar
dterei committed
533
                -- If ds is [] we get ([], Nothing)
dterei's avatar
dterei committed
534

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

539 540
        -- Get TH-generated top-level declarations and make sure they don't
        -- contain any splices since we don't handle that at the moment
541
        --
542
        -- The plumbing here is a bit odd: see #10853
543 544 545 546 547 548 549 550 551
      ; 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
552 553 554 555 556 557 558
                        { Nothing -> return ()
                        ; Just (SpliceDecl _ (dL->L loc _) _, _) ->
                            setSrcSpan loc
                            $ addErr (text
                                ("Declaration splices are not "
                                  ++ "permitted inside top-level "
                                  ++ "declarations added with addTopDecls"))
559
                        ; Just (XSpliceDecl nec, _) -> noExtCon nec
560 561 562 563
                        }
                      -- Rename TH-generated top-level declarations
                    ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env
                        $ rnTopSrcDecls th_group
564

565
                      -- Dump generated top-level declarations
566
                    ; let msg = "top-level declarations added with addTopDecls"
567 568 569 570 571
                    ; traceSplice
                        $ SpliceInfo { spliceDescription = msg
                                     , spliceIsDecl    = True
                                     , spliceSource    = Nothing
                                     , spliceGenerated = ppr th_rn_decls }
572 573 574 575
                    ; return (tcg_env, appendGroups rn_decls th_rn_decls)
                    }

      -- Type check all declarations
576 577 578 579 580 581
      -- NB: set the env **before** captureTopConstraints so that error messages
      -- get reported w.r.t. the right GlobalRdrEnv. It is for this reason that
      -- the captureTopConstraints must go here, not in tcRnSrcDecls.
      ; ((tcg_env, tcl_env), lie1) <- setGblEnv tcg_env $
                                      captureTopConstraints $
                                      tcTopSrcDecls rn_decls
582

dterei's avatar
dterei committed
583
        -- If there is no splice, we're nearly done
gmainland's avatar
gmainland committed
584 585
      ; setEnvs (tcg_env, tcl_env) $
        case group_tail of
586
          { Nothing -> return (tcg_env, tcl_env, lie1)
587

gmainland's avatar
gmainland committed
588
            -- If there's a splice, we must carry on
589
          ; Just (SpliceDecl _ (dL->L loc splice) _, rest_ds) ->
590 591 592
            do { recordTopLevelSpliceLoc loc

                 -- Rename the splice expression, and get its supporting decls
593
               ; (spliced_decls, splice_fvs) <- rnTopSpliceDecls splice
gmainland's avatar
gmainland committed
594 595

                 -- Glue them on the front of the remaining decls and loop
596 597 598 599 600
               ; (tcg_env, tcl_env, lie2) <-
                   setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
                   tc_rn_src_decls (spliced_decls ++ rest_ds)

               ; return (tcg_env, tcl_env, lie1 `andWC` lie2)
gmainland's avatar
gmainland committed
601
               }
602
          ; Just (XSpliceDecl nec, _) -> noExtCon nec
gmainland's avatar
gmainland committed
603 604
          }
      }
605

Austin Seipp's avatar
Austin Seipp committed
606 607 608
{-
************************************************************************
*                                                                      *
dterei's avatar
dterei committed
609 610
        Compiling hs-boot source files, and
        comparing the hi-boot interface with the real thing
Austin Seipp's avatar
Austin Seipp committed
611 612 613
*                                                                      *
************************************************************************
-}
614

615
tcRnHsBootDecls :: HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv
616
tcRnHsBootDecls hsc_src decls
617
   = do { (first_group, group_tail) <- findSplice decls
618

dterei's avatar
dterei committed
619
                -- Rename the declarations
620 621 622 623 624 625
        ; (tcg_env, HsGroup { hs_tyclds = tycl_decls
                            , hs_derivds = deriv_decls
                            , hs_fords  = for_decls
                            , hs_defds  = def_decls
                            , hs_ruleds = rule_decls
                            , hs_annds  = _
626
                            , hs_valds  = XValBindsLR (NValBinds val_binds val_sigs) })
627
              <- rnTopSrcDecls first_group
628

629 630
        -- The empty list is for extra dependencies coming from .hs-boot files
        -- See Note [Extra dependencies from .hs-boot files] in RnSource
631

632 633 634
        ; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do {
              -- NB: setGblEnv **before** captureTopConstraints so that
              -- if the latter reports errors, it knows what's in scope
dterei's avatar
dterei committed
635 636 637

                -- Check for illegal declarations
        ; case group_tail of
638
             Just (SpliceDecl _ d _, _) -> badBootDecl hsc_src "splice" d
639 640
             Just (XSpliceDecl nec, _)  -> noExtCon nec
             Nothing                    -> return ()
641 642 643
        ; mapM_ (badBootDecl hsc_src "foreign") for_decls
        ; mapM_ (badBootDecl hsc_src "default") def_decls
        ; mapM_ (badBootDecl hsc_src "rule")    rule_decls
dterei's avatar
dterei committed
644

Gabor Greif's avatar
Gabor Greif committed
645
                -- Typecheck type/class/instance decls
646
        ; traceTc "Tc2 (boot)" empty
dterei's avatar
dterei committed
647
        ; (tcg_env, inst_infos, _deriv_binds)
648
             <- tcTyClsInstDecls tycl_decls deriv_decls val_binds
dterei's avatar
dterei committed
649 650
        ; setGblEnv tcg_env     $ do {

Ben Gamari's avatar
Ben Gamari committed
651 652 653 654
        -- Emit Typeable bindings
        ; tcg_env <- mkTypeableBinds
        ; setGblEnv tcg_env $ do {

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

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

dterei's avatar
dterei committed
664 665
                -- Make the final type-env
                -- Include the dfun_ids so that their type sigs
dterei's avatar
dterei committed
666
                -- are written into the interface file.
dterei's avatar
dterei committed
667 668
        ; let { type_env0 = tcg_type_env gbl_env
              ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
Edward Z. Yang's avatar
Edward Z. Yang committed
669
              ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids
dterei's avatar
dterei committed
670 671 672 673
              ; dfun_ids = map iDFunId inst_infos
              }

        ; setGlobalTypeEnv gbl_env type_env2
Ben Gamari's avatar
Ben Gamari committed
674
   }}}
675
   ; traceTc "boot" (ppr lie); return gbl_env }
676

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

Austin Seipp's avatar
Austin Seipp committed
687
{-
688 689
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
690
-}
691

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

Simon Peyton Jones's avatar
Simon Peyton Jones committed
698 699
checkHiBootIface tcg_env boot_info
  | NoSelfBoot <- boot_info  -- Common case
dterei's avatar
dterei committed
700
  = return tcg_env
701

Simon Peyton Jones's avatar
Simon Peyton Jones committed
702 703 704 705 706 707 708 709
  | 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
710
  = do  { -- This code is tricky, see Note [DFun knot-tying]
711
        ; dfun_prs <- checkHiBootIface' local_insts local_type_env
712
                                        local_exports boot_details
713

714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730
        -- Now add the boot-dfun bindings  $fxblah = $fblah
        -- to (a) the type envt, and (b) the top-level bindings
        ; let boot_dfuns = map fst dfun_prs
              type_env'  = extendTypeEnvWithIds local_type_env boot_dfuns
              dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
                                     | (boot_dfun, dfun) <- dfun_prs ]
              tcg_env_w_binds
                = tcg_env { tcg_binds = binds `unionBags` dfun_binds }

        ; type_env' `seq`
             -- Why the seq?  Without, we will put a TypeEnv thunk in
             -- tcg_type_env_var.  That thunk will eventually get
             -- forced if we are typechecking interfaces, but that
             -- is no good if we are trying to typecheck the very
             -- DFun we were going to put in.
             -- TODO: Maybe setGlobalTypeEnv should be strict.
          setGlobalTypeEnv tcg_env_w_binds type_env' }
731

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

734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769
{- Note [DFun impedance matching]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We return a list of "impedance-matching" bindings for the dfuns
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: the name of a dfun is not
uniquely determined by its type; there might be multiple dfuns
which, individually, would map to the same name (in which case
we have to disambiguate them.)  There's no way for the hi file
to know exactly what disambiguation to use... without looking
at the hi-boot file itself.

In fact, the names will always differ because we always pick names
prefixed with "$fx" for boot dfuns, and "$f" for real dfuns
(so that this impedance matching is always possible).

Note [DFun knot-tying]
~~~~~~~~~~~~~~~~~~~~~~
The 'SelfBootInfo' that is fed into 'checkHiBootIface' comes from
typechecking the hi-boot file that we are presently implementing.
Suppose we are typechecking the module A: when we typecheck the
hi-boot file, whenever we see an identifier A.T, we knot-tie this
identifier to the *local* type environment (via if_rec_types.)  The
contract then is that we don't *look* at 'SelfBootInfo' until we've
finished typechecking the module and updated the type environment with
the new tycons and ids.

This most works well, but there is one problem: DFuns!  We do not want
to look at the mb_insts of the ModDetails in SelfBootInfo, because a
dfun in one of those ClsInsts is gotten (in TcIface.tcIfaceInst) by a
(lazily evaluated) lookup in the if_rec_types.  We could extend the
type env, do a setGloblaTypeEnv etc; but that all seems very indirect.
It is much more directly simply to extract the DFunIds from the
md_types of the SelfBootInfo.

770
See #4003, #16038 for why we need to take care here.
771
-}
772

773
checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo]
774
                  -> ModDetails -> TcM [(Id, Id)]
775 776 777 778
-- Variant which doesn't require a full TcGblEnv; you could get the
-- local components from another ModDetails.
checkHiBootIface'
        local_insts local_type_env local_exports
779 780 781
        (ModDetails { md_types = boot_type_env
                    , md_fam_insts = boot_fam_insts
                    , md_exports = boot_exports })
dterei's avatar
dterei committed
782
  = do  { traceTc "checkHiBootIface" $ vcat
783
             [ ppr boot_type_env, ppr boot_exports]
784

dterei's avatar
dterei committed
785 786
                -- Check the exports of the boot module, one by one
        ; mapM_ check_export boot_exports
787

dterei's avatar
dterei committed
788 789 790 791
                -- Check for no family instances
        ; unless (null boot_fam_insts) $
            panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
                   "instances in boot files yet...")
792
            -- FIXME: Why?  The actual comparison is not hard, but what would
dterei's avatar
dterei committed
793 794
            --        be the equivalent to the dfun bindings returned for class
            --        instances?  We can't easily equate tycons...
795

dterei's avatar
dterei committed
796
                -- Check instance declarations
Gabor Greif's avatar
Gabor Greif committed
797
                -- and generate an impedance-matching binding
798
        ; mb_dfun_prs <- mapM check_cls_inst boot_dfuns
799

800
        ; failIfErrsM
801

802
        ; return (catMaybes mb_dfun_prs) }
803

804
  where
805 806 807 808 809 810
    boot_dfun_names = map idName boot_dfuns
    boot_dfuns      = filter isDFunId $ typeEnvIds boot_type_env
       -- NB: boot_dfuns is /not/ defined thus: map instanceDFunId md_insts
       --     We don't want to look at md_insts!
       --     Why not?  See Note [DFun knot-tying]

dterei's avatar
dterei committed
811
    check_export boot_avail     -- boot_avail is exported by the boot iface
812 813
      | name `elem` boot_dfun_names = return ()
      | isWiredInName name          = return () -- No checking for wired-in names.  In particular,
dterei's avatar
dterei committed
814 815
                                                -- 'error' is handled by a rather gross hack
                                                -- (see comments in GHC.Err.hs-boot)
816

dterei's avatar
dterei committed
817
        -- Check that the actual module exports the same thing
818
      | not (null missing_names)
dterei's avatar
dterei committed
819
      = addErrAt (nameSrcSpan (head missing_names))
820
                 (missingBootThing True (head missing_names) "exported by")
821

dterei's avatar
dterei committed
822 823
        -- 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)
824
      | isNothing mb_boot_thing = return ()
825

dterei's avatar
dterei committed
826
        -- Check that the actual module also defines the thing, and