TcRnDriver.hs 110 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
12
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NondecreasingIndentation #-}
Edward Z. Yang's avatar
Edward Z. Yang committed
13
14
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
15

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

43
import {-# SOURCE #-} TcSplice ( finishTH )
44
import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )
45
46
47
import IfaceEnv( externaliseName )
import TcHsType
import TcMatches
48
import Inst( deeplyInstantiate )
49
import TcUnify( checkConstraints )
50
51
52
53
54
import RnTypes
import RnExpr
import MkId
import TidyPgm    ( globaliseAndTidyId )
import TysWiredIn ( unitTy, mkListTy )
55
#ifdef GHCI
56
57
import DynamicLoading ( loadPlugins )
import Plugins ( tcPlugin )
58
59
#endif

60
61
import DynFlags
import HsSyn
62
63
import IfaceSyn ( ShowSub(..), showToHeader )
import IfaceType( ShowForAllFlag(..) )
64
65
66
67
import PrelNames
import RdrName
import TcHsSyn
import TcExpr
68
import TcRnMonad
69
import TcRnExports
70
import TcEvidence
71
import qualified BooleanFormula as BF
72
import PprTyThing( pprTyThingInContext )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
73
import MkIface( tyThingToIfaceDecl )
74
import Coercion( pprCoAxiom )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
75
import CoreFVs( orphNamesOfFamInst )
76
import FamInst
77
78
import InstEnv
import FamInstEnv
79
import TcAnnotations
80
import TcBinds
81
import HeaderInfo       ( mkPrelImports )
82
83
84
85
86
87
import TcDefaults
import TcEnv
import TcRules
import TcForeign
import TcInstDcls
import TcIface
88
import TcMType
89
import TcType
90
91
import TcSimplify
import TcTyClsDecls
92
import TcTypeable ( mkTypeableBinds )
Edward Z. Yang's avatar
Edward Z. Yang committed
93
import TcBackpack
94
95
96
97
98
99
import LoadIface
import RnNames
import RnEnv
import RnSource
import ErrUtils
import Id
100
import VarEnv
Simon Marlow's avatar
Simon Marlow committed
101
import Module
102
import UniqDFM
103
import Name
104
import NameEnv
105
import NameSet
106
import Avail
107
108
109
import TyCon
import SrcLoc
import HscTypes
110
import ListSetOps
111
import Outputable
Gergő Érdi's avatar
Gergő Érdi committed
112
import ConLike
113
114
115
import DataCon
import Type
import Class
116
import BasicTypes hiding( SuccessFlag(..) )
117
import CoAxiom
118
import Annotations
119
import Data.List ( sortBy )
120
import Data.Ord
121
import FastString
122
import Maybes
123
124
import Util
import Bag
125
import Inst (tcGetInsts)
126
import qualified GHC.LanguageExtensions as LangExt
127
import Data.Data ( Data )
128
129
import HsDumpAst
import qualified Data.Set as S
130

131
import Control.Monad
132

133
#include "HsVersions.h"
134

Austin Seipp's avatar
Austin Seipp committed
135
136
137
{-
************************************************************************
*                                                                      *
dterei's avatar
dterei committed
138
        Typecheck and rename a module
Austin Seipp's avatar
Austin Seipp committed
139
140
141
*                                                                      *
************************************************************************
-}
142

143
-- | Top level entry point for typechecker and renamer
dterei's avatar
dterei committed
144
tcRnModule :: HscEnv
dterei's avatar
dterei committed
145
146
           -> HscSource
           -> Bool              -- True <=> save renamed syntax
147
           -> HsParsedModule
dterei's avatar
dterei committed
148
           -> IO (Messages, Maybe TcGblEnv)
149

150
tcRnModule hsc_env hsc_src save_rn_syntax
151
   parsedModule@HsParsedModule {hpm_module=L loc this_module}
152
 | RealSrcSpan real_loc <- loc
153
154
155
156
157
 = withTiming (pure dflags)
              (text "Renamer/typechecker"<+>brackets (ppr this_mod))
              (const ()) $
   initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $
          withTcPlugins hsc_env $
158

159
          tcRnModuleTcRnM hsc_env hsc_src parsedModule pair
dterei's avatar
dterei committed
160

161
162
163
164
  | otherwise
  = return ((emptyBag, unitBag err_msg), Nothing)

  where
165
    dflags = hsc_dflags hsc_env
166
167
168
169
170
171
172
173
174
175
176
177
    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
178

179

180
181


182
183
184
185
186
tcRnModuleTcRnM :: HscEnv
                -> HscSource
                -> HsParsedModule
                -> (Module, SrcSpan)
                -> TcRn TcGblEnv
187
-- Factored out separately from tcRnModule so that a Core plugin can
188
-- call the type checker directly
189
tcRnModuleTcRnM hsc_env hsc_src
190
191
192
193
194
195
196
197
198
                (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 $
Edward Z. Yang's avatar
Edward Z. Yang committed
199
   do { let { explicit_mod_hdr = isJust maybe_mod } ;
Simon Peyton Jones's avatar
Simon Peyton Jones committed
200
201
202
203
204

                -- 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
Edward Z. Yang's avatar
Edward Z. Yang committed
205
        tcg_env <- getGblEnv ;
Simon Peyton Jones's avatar
Simon Peyton Jones committed
206
207
        boot_info <- tcHiBootIface hsc_src this_mod ;
        setGblEnv (tcg_env { tcg_self_boot = boot_info }) $ do {
208
209

        -- Deal with imports; first add implicit prelude
210
        implicit_prelude <- xoptM LangExt.ImplicitPrelude;
211
212
213
        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
214
        whenWOptM Opt_WarnImplicitPrelude $
215
216
             when (notNull prel_imports) $
                  addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn) ;
217

Edward Z. Yang's avatar
Edward Z. Yang committed
218
219
220
221
222
223
224
225
226
227
228
229
230
231
        -- TODO This is a little skeevy; maybe handle a bit more directly
        let { simplifyImport (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, 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
dterei's avatar
dterei committed
232
        tcg_env <- {-# SCC "tcRnImports" #-}
Edward Z. Yang's avatar
Edward Z. Yang committed
233
                   tcRnImports hsc_env all_imports ;
234

Austin Seipp's avatar
Austin Seipp committed
235
          -- If the whole module is warned about or deprecated
236
237
          -- (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
238
239
240
        let { tcg_env1 = case mod_deprec of
                         Just (L _ txt) -> tcg_env { tcg_warns = WarnAll txt }
                         Nothing        -> tcg_env
241
            } ;
242

243
        setGblEnv tcg_env1 $ do {
dterei's avatar
dterei committed
244
245

                -- Rename and type check the declarations
246
        traceRn "rn1a" empty ;
247
        tcg_env <- if isHsBootOrSig hsc_src then
248
                        tcRnHsBootDecls hsc_src local_decls
dterei's avatar
dterei committed
249
                   else
dterei's avatar
dterei committed
250
                        {-# SCC "tcRnSrcDecls" #-}
251
                        tcRnSrcDecls explicit_mod_hdr local_decls ;
dterei's avatar
dterei committed
252
253
254
        setGblEnv tcg_env               $ do {

                -- Process the export list
255
        traceRn "rn4a: before exports" empty;
256
        tcg_env <- tcRnExports explicit_mod_hdr export_ies tcg_env ;
257
        traceRn "rn4b: after exports" empty ;
258

259
                -- Check that main is exported (must be after tcRnExports)
260
261
        checkMainExported tcg_env ;

dterei's avatar
dterei committed
262
263
        -- 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
264
        tcg_env <- checkHiBootIface tcg_env boot_info ;
265

dterei's avatar
dterei committed
266
        -- The new type env is already available to stuff slurped from
267
        -- interface files, via TcEnv.setGlobalTypeEnv
dterei's avatar
dterei committed
268
269
        -- 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
270
        -- which may be mentioned in imported unfoldings
271

dterei's avatar
dterei committed
272
273
274
                -- 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 }) ;
275

dterei's avatar
dterei committed
276
                -- Report unused names
277
278
279
                -- Do this /after/ type inference, so that when reporting
                -- a function with no type signature we can give the
                -- inferred type
dterei's avatar
dterei committed
280
        reportUnusedNames export_ies tcg_env ;
281

282
283
284
285
                -- add extra source files to tcg_dependent_files
        addDependentFiles src_files ;

                -- Dump output and return
dterei's avatar
dterei committed
286
287
        tcDump tcg_env ;
        return tcg_env
Edward Z. Yang's avatar
Edward Z. Yang committed
288
    }}}}
289
290
291

implicitPreludeWarn :: SDoc
implicitPreludeWarn
292
  = text "Module `Prelude' implicitly imported"
293

Austin Seipp's avatar
Austin Seipp committed
294
295
296
{-
************************************************************************
*                                                                      *
dterei's avatar
dterei committed
297
                Import declarations
Austin Seipp's avatar
Austin Seipp committed
298
299
300
*                                                                      *
************************************************************************
-}
301

302
303
tcRnImports :: HscEnv -> [LImportDecl RdrName] -> TcM TcGblEnv
tcRnImports hsc_env import_decls
304
  = do  { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ;
dterei's avatar
dterei committed
305

306
        ; this_mod <- getModule
307
        ; let { dep_mods :: DModuleNameEnv (ModuleName, IsBootInterface)
Austin Seipp's avatar
Austin Seipp committed
308
              ; dep_mods = imp_dep_mods imports
dterei's avatar
dterei committed
309
310
311
312

                -- 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
313
314
315
316
                -- 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
317
              ; want_instances :: ModuleName -> Bool
318
              ; want_instances mod = mod `elemUDFM` dep_mods
dterei's avatar
dterei committed
319
                                   && mod /= moduleName this_mod
dterei's avatar
dterei committed
320
              ; (home_insts, home_fam_insts) = hptInstances hsc_env
321
                                                            want_instances
dterei's avatar
dterei committed
322
              } ;
323

dterei's avatar
dterei committed
324
                -- Record boot-file info in the EPS, so that it's
dterei's avatar
dterei committed
325
326
                -- visible to loadHiBootInterface in tcRnSrcDecls,
                -- and any other incrementally-performed imports
327
        ; updateEps_ (\eps -> eps { eps_is_boot = udfmToUfm dep_mods }) ;
328

dterei's avatar
dterei committed
329
                -- Update the gbl env
dterei's avatar
dterei committed
330
331
        ; updGblEnv ( \ gbl ->
            gbl {
332
              tcg_rdr_env      = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env,
dterei's avatar
dterei committed
333
              tcg_imports      = tcg_imports gbl `plusImportAvails` imports,
334
              tcg_rn_imports   = rn_imports,
dterei's avatar
dterei committed
335
              tcg_inst_env     = extendInstEnvList (tcg_inst_env gbl) home_insts,
dterei's avatar
dterei committed
336
              tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
337
                                                      home_fam_insts,
dterei's avatar
dterei committed
338
339
340
              tcg_hpc          = hpc_info
            }) $ do {

341
        ; traceRn "rn1" (ppr (imp_dep_mods imports))
dterei's avatar
dterei committed
342
                -- Fail if there are any errors so far
dterei's avatar
dterei committed
343
                -- The error printing (if needed) takes advantage
dterei's avatar
dterei committed
344
345
346
347
                -- of the tcg_env we have now set
--      ; traceIf (text "rdr_env: " <+> ppr rdr_env)
        ; failIfErrsM

348
349
350
351
352
353
354
355
356
                -- 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.)
357
        ; loadModuleInterfaces (text "Loading orphan modules")
358
                               (filter (/= this_mod) (imp_orphs imports))
359

360
361
                -- Check type-family consistency between imports.
                -- See Note [The type family instance consistency story]
362
        ; traceRn "rn1: checking family instance consistency" empty
dterei's avatar
dterei committed
363
        ; let { dir_imp_mods = moduleEnvKeys
dterei's avatar
dterei committed
364
                             . imp_mods
dterei's avatar
dterei committed
365
                             $ imports }
366
        ; tcg_env <- checkFamInstConsistency (imp_finsts imports) dir_imp_mods ;
367

368
        ; return tcg_env } }
369

Austin Seipp's avatar
Austin Seipp committed
370
371
372
{-
************************************************************************
*                                                                      *
dterei's avatar
dterei committed
373
        Type-checking the top level of a module
Austin Seipp's avatar
Austin Seipp committed
374
375
376
*                                                                      *
************************************************************************
-}
377

Simon Peyton Jones's avatar
Simon Peyton Jones committed
378
tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all
379
380
             -> [LHsDecl RdrName]               -- Declarations
             -> TcM TcGblEnv
381
tcRnSrcDecls explicit_mod_hdr decls
382
 = do { -- Do all the declarations
383
384
      ; ((tcg_env, tcl_env), lie) <- captureTopConstraints $
              do { (tcg_env, tcl_env) <- tc_rn_src_decls decls
385
386

                   -- Check for the 'main' declaration
387
                   -- Must do this inside the captureTopConstraints
Simon Peyton Jones's avatar
Simon Peyton Jones committed
388
389
390
391
                 ; tcg_env <- setEnvs (tcg_env, tcl_env) $
                              checkMain explicit_mod_hdr
                 ; return (tcg_env, tcl_env) }

392
      ; setEnvs (tcg_env, tcl_env) $ do {
393

394
             --         Simplify constraints
dterei's avatar
dterei committed
395
             --
dterei's avatar
dterei committed
396
             -- We do this after checkMain, so that we use the type info
dterei's avatar
dterei committed
397
             -- that checkMain adds
dterei's avatar
dterei committed
398
             --
dterei's avatar
dterei committed
399
400
             -- We do it with both global and local env in scope:
             --  * the global env exposes the instances to simplifyTop
dterei's avatar
dterei committed
401
             --  * the local env exposes the local Ids to simplifyTop,
dterei's avatar
dterei committed
402
             --    so that we get better error messages (monomorphism restriction)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
403
      ; new_ev_binds <- {-# SCC "simplifyTop" #-}
404
405
                        simplifyTop lie

406
407
408
        -- Emit Typeable bindings
      ; tcg_env <- mkTypeableBinds

409
410
        -- Finalizers must run after constraints are simplified, or some types
        -- might not be complete when using reify (see #12777).
411
      ; (tcg_env, tcl_env) <- setGblEnv tcg_env run_th_modfinalizers
412
413
414
415
      ; setEnvs (tcg_env, tcl_env) $ do {

      ; finishTH

Simon Peyton Jones's avatar
Simon Peyton Jones committed
416
      ; traceTc "Tc9" empty
417

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

423
424
        -- Zonk the final code.  This must be done last.
        -- Even simplifyTop may do some unification.
425
        -- This pass also warns about missing type signatures
Simon Peyton Jones's avatar
Simon Peyton Jones committed
426
      ; let { TcGblEnv { tcg_type_env  = type_env,
427
428
429
430
431
432
                         tcg_binds     = binds,
                         tcg_ev_binds  = cur_ev_binds,
                         tcg_imp_specs = imp_specs,
                         tcg_rules     = rules,
                         tcg_vects     = vects,
                         tcg_fords     = fords } = tcg_env
433
            ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
434

niteria's avatar
niteria committed
435
      ; (bind_env, ev_binds', binds', fords', imp_specs', rules', vects')
436
            <- {-# SCC "zonkTopDecls" #-}
437
               zonkTopDecls all_ev_binds binds rules vects
438
                            imp_specs fords ;
Matthew Pickering's avatar
Matthew Pickering committed
439
      ; traceTc "Tc11" empty
dterei's avatar
dterei committed
440

niteria's avatar
niteria committed
441
      ; let { final_type_env = plusTypeEnv type_env bind_env
442
443
444
            ; tcg_env' = tcg_env { tcg_binds    = binds',
                                   tcg_ev_binds = ev_binds',
                                   tcg_imp_specs = imp_specs',
dterei's avatar
dterei committed
445
446
                                   tcg_rules    = rules',
                                   tcg_vects    = vects',
447
448
                                   tcg_fords    = fords' } } ;

Simon Peyton Jones's avatar
Simon Peyton Jones committed
449
      ; setGlobalTypeEnv tcg_env' final_type_env
Austin Seipp's avatar
Austin Seipp committed
450

451
   }
452
   } }
453

454
455
456
457
458
459
460
461
462
463
-- | 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 []
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
    (envs, lie) <- captureTopConstraints $ do
      sequence_ th_modfinalizers
      -- Finalizers can add top-level declarations with addTopDecls.
      tc_rn_src_decls []
    setEnvs envs $ do
      -- 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" #-}
                      simplifyTop lie
      updGblEnv (\tcg_env ->
        tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env `unionBags` new_ev_binds }
        )
        -- addTopDecls can add declarations which add new finalizers.
        run_th_modfinalizers
479

Simon Peyton Jones's avatar
Simon Peyton Jones committed
480
tc_rn_src_decls :: [LHsDecl RdrName]
gmainland's avatar
gmainland committed
481
                -> TcM (TcGblEnv, TcLclEnv)
dterei's avatar
dterei committed
482
-- Loops around dealing with each top level inter-splice group
483
-- in turn, until it's dealt with the entire module
Simon Peyton Jones's avatar
Simon Peyton Jones committed
484
tc_rn_src_decls ds
485
 = {-# SCC "tc_rn_src_decls" #-}
gmainland's avatar
gmainland committed
486
   do { (first_group, group_tail) <- findSplice ds
dterei's avatar
dterei committed
487
                -- If ds is [] we get ([], Nothing)
dterei's avatar
dterei committed
488

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

493
494
        -- Get TH-generated top-level declarations and make sure they don't
        -- contain any splices since we don't handle that at the moment
495
496
        --
        -- The plumbing here is a bit odd: see Trac #10853
497
498
499
500
501
502
503
504
505
506
507
508
      ; 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 $
509
                               addErr (text "Declaration splices are not permitted inside top-level declarations added with addTopDecls")
510
                        } ;
Austin Seipp's avatar
Austin Seipp committed
511

512
513
                    -- Rename TH-generated top-level declarations
                    ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env $
Simon Peyton Jones's avatar
Simon Peyton Jones committed
514
                      rnTopSrcDecls th_group
515
516

                    -- Dump generated top-level declarations
517
                    ; let msg = "top-level declarations added with addTopDecls"
518
519
520
521
                    ; traceSplice $ SpliceInfo { spliceDescription = msg
                                               , spliceIsDecl    = True
                                               , spliceSource    = Nothing
                                               , spliceGenerated = ppr th_rn_decls }
522
523
524
525
526

                    ; return (tcg_env, appendGroups rn_decls th_rn_decls)
                    }

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

dterei's avatar
dterei committed
530
        -- If there is no splice, we're nearly done
gmainland's avatar
gmainland committed
531
532
      ; setEnvs (tcg_env, tcl_env) $
        case group_tail of
Simon Peyton Jones's avatar
Simon Peyton Jones committed
533
          { Nothing -> return (tcg_env, tcl_env)
534

gmainland's avatar
gmainland committed
535
            -- If there's a splice, we must carry on
536
537
538
539
540
541
          ; Just (SpliceDecl (L loc splice) _, rest_ds) ->
            do { recordTopLevelSpliceLoc loc

                 -- Rename the splice expression, and get its supporting decls
               ; (spliced_decls, splice_fvs) <- checkNoErrs (rnTopSpliceDecls
                                                             splice)
gmainland's avatar
gmainland committed
542
543
544

                 -- 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
545
                 tc_rn_src_decls (spliced_decls ++ rest_ds)
gmainland's avatar
gmainland committed
546
547
548
               }
          }
      }
549

Austin Seipp's avatar
Austin Seipp committed
550
551
552
{-
************************************************************************
*                                                                      *
dterei's avatar
dterei committed
553
554
        Compiling hs-boot source files, and
        comparing the hi-boot interface with the real thing
Austin Seipp's avatar
Austin Seipp committed
555
556
557
*                                                                      *
************************************************************************
-}
558

559
560
tcRnHsBootDecls :: HscSource -> [LHsDecl RdrName] -> TcM TcGblEnv
tcRnHsBootDecls hsc_src decls
561
   = do { (first_group, group_tail) <- findSplice decls
562

dterei's avatar
dterei committed
563
                -- Rename the declarations
564
565
566
567
568
569
570
571
572
        ; (tcg_env, HsGroup { hs_tyclds = tycl_decls
                            , hs_derivds = deriv_decls
                            , hs_fords  = for_decls
                            , hs_defds  = def_decls
                            , hs_ruleds = rule_decls
                            , hs_vects  = vect_decls
                            , hs_annds  = _
                            , hs_valds  = ValBindsOut val_binds val_sigs })
              <- rnTopSrcDecls first_group
573
574
        -- The empty list is for extra dependencies coming from .hs-boot files
        -- See Note [Extra dependencies from .hs-boot files] in RnSource
575
        ; (gbl_env, lie) <- captureTopConstraints $ setGblEnv tcg_env $ do {
dterei's avatar
dterei committed
576
577
578
579


                -- Check for illegal declarations
        ; case group_tail of
580
             Just (SpliceDecl d _, _) -> badBootDecl hsc_src "splice" d
dterei's avatar
dterei committed
581
             Nothing                  -> return ()
582
583
584
585
        ; 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
586

Gabor Greif's avatar
Gabor Greif committed
587
                -- Typecheck type/class/instance decls
588
        ; traceTc "Tc2 (boot)" empty
dterei's avatar
dterei committed
589
        ; (tcg_env, inst_infos, _deriv_binds)
590
             <- tcTyClsInstDecls tycl_decls deriv_decls val_binds
dterei's avatar
dterei committed
591
592
        ; setGblEnv tcg_env     $ do {

Ben Gamari's avatar
Ben Gamari committed
593
594
595
596
        -- Emit Typeable bindings
        ; tcg_env <- mkTypeableBinds
        ; setGblEnv tcg_env $ do {

dterei's avatar
dterei committed
597
                -- Typecheck value declarations
dterei's avatar
dterei committed
598
        ; traceTc "Tc5" empty
599
        ; val_ids <- tcHsBootSigs val_binds val_sigs
dterei's avatar
dterei committed
600
601
602
603

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

dterei's avatar
dterei committed
606
607
                -- Make the final type-env
                -- Include the dfun_ids so that their type sigs
dterei's avatar
dterei committed
608
                -- are written into the interface file.
dterei's avatar
dterei committed
609
610
        ; let { type_env0 = tcg_type_env gbl_env
              ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
Edward Z. Yang's avatar
Edward Z. Yang committed
611
              ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids
dterei's avatar
dterei committed
612
613
614
615
              ; dfun_ids = map iDFunId inst_infos
              }

        ; setGlobalTypeEnv gbl_env type_env2
Ben Gamari's avatar
Ben Gamari committed
616
   }}}
617
   ; traceTc "boot" (ppr lie); return gbl_env }
618

619
badBootDecl :: HscSource -> String -> Located decl -> TcM ()
620
badBootDecl hsc_src what (L loc _)
dterei's avatar
dterei committed
621
  = addErrAt loc (char 'A' <+> text what
622
      <+> text "declaration is not (currently) allowed in a"
623
      <+> (case hsc_src of
624
625
            HsBootFile -> text "hs-boot"
            HsigFile -> text "hsig"
626
            _ -> panic "badBootDecl: should be an hsig or hs-boot file")
627
      <+> text "file")
628

Austin Seipp's avatar
Austin Seipp committed
629
{-
630
631
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
632
-}
633

Simon Peyton Jones's avatar
Simon Peyton Jones committed
634
checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv
635
636
-- Compare the hi-boot file for this module (if there is one)
-- with the type environment we've just come up with
637
638
-- In the common case where there is no hi-boot file, the list
-- of boot_names is empty.
639

Simon Peyton Jones's avatar
Simon Peyton Jones committed
640
641
checkHiBootIface tcg_env boot_info
  | NoSelfBoot <- boot_info  -- Common case
dterei's avatar
dterei committed
642
  = return tcg_env
643

Simon Peyton Jones's avatar
Simon Peyton Jones committed
644
645
646
647
648
649
650
651
  | 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
652
653
654
655
656
657
658
659
660
661
662
  = do  { -- This code is tricky, see Note [DFun knot-tying]
        ; let boot_dfuns = filter isDFunId (typeEnvIds (md_types boot_details))
              type_env'  = extendTypeEnvWithIds local_type_env boot_dfuns
          -- 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.
        ; tcg_env <- type_env' `seq` setGlobalTypeEnv tcg_env type_env'
        ; dfun_prs <- checkHiBootIface' local_insts type_env'
663
                                        local_exports boot_details
664
        ; let dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
665
666
                                     | (boot_dfun, dfun) <- dfun_prs ]

667
        ; return tcg_env { tcg_binds = binds `unionBags` dfun_binds } }
668

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

671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
-- 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!
-- In general, it's not possible to know a priori what an
-- hs-boot file named a DFun (see Note [DFun impedance matching]),
-- so we look at the ClsInsts from the boot file to figure out
-- what DFuns to add to the type environment.  But we're not
-- allowed to poke the DFuns of the ClsInsts in the SelfBootInfo
-- until we've added the DFuns to the type environment.  A
-- Gordian knot!
--
-- We cut the knot by a little trick: we first *unconditionally*
-- add all of the boot-declared DFuns to the type environment
-- (so that knot tying works, see Trac #4003), without the
-- actual bindings for them.  Then, we compute the impedance
-- matching bindings, and add them to the environment.
--
-- There is one subtlety to doing this: we have to get the
-- DFuns from md_types, not md_insts, even though involves
-- filtering a bunch of TyThings we don't care about.  The
-- reason is only the TypeEnv in md_types has the actual
-- Id we want to add to the environment; the DFun fields
-- in md_insts are typechecking thunks that will attempt to
-- go through if_rec_types to lookup the real Id... but
-- that's what we're trying to setup right now.

707
checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo]
708
                  -> ModDetails -> TcM [(Id, Id)]
709
710
-- Variant which doesn't require a full TcGblEnv; you could get the
-- local components from another ModDetails.
711
--
712
713
-- Note [DFun impedance matching]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Gabor Greif's avatar
Gabor Greif committed
714
-- We return a list of "impedance-matching" bindings for the dfuns
715
716
717
-- defined in the hs-boot file, such as
--           $fxEqT = $fEqT
-- We need these because the module and hi-boot file might differ in
718
719
720
721
722
723
724
725
726
727
-- 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).
728
729
730
731
732

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
733
  = do  { traceTc "checkHiBootIface" $ vcat
734
             [ ppr boot_type_env, ppr boot_insts, ppr boot_exports]
735

dterei's avatar
dterei committed
736
737
                -- Check the exports of the boot module, one by one
        ; mapM_ check_export boot_exports
738

dterei's avatar
dterei committed
739
740
741
742
                -- Check for no family instances
        ; unless (null boot_fam_insts) $
            panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
                   "instances in boot files yet...")
743
            -- FIXME: Why?  The actual comparison is not hard, but what would
dterei's avatar
dterei committed
744
745
            --        be the equivalent to the dfun bindings returned for class
            --        instances?  We can't easily equate tycons...
746

dterei's avatar
dterei committed
747
                -- Check instance declarations
Gabor Greif's avatar
Gabor Greif committed
748
                -- and generate an impedance-matching binding
dterei's avatar
dterei committed
749
        ; mb_dfun_prs <- mapM check_inst boot_insts
750

751
        ; failIfErrsM
752

753
        ; return (catMaybes mb_dfun_prs) }
754

755
  where
dterei's avatar
dterei committed
756
    check_export boot_avail     -- boot_avail is exported by the boot iface
dterei's avatar
dterei committed
757
      | name `elem` dfun_names = return ()
dterei's avatar
dterei committed
758
759
760
      | 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)
761

dterei's avatar
dterei committed
762
        -- Check that the actual module exports the same thing
763
      | not (null missing_names)
dterei's avatar
dterei committed
764
      = addErrAt (nameSrcSpan (head missing_names))
765
                 (missingBootThing True (head missing_names) "exported by")
766

dterei's avatar
dterei committed
767
768
        -- 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)
769
      | isNothing mb_boot_thing = return ()
770

dterei's avatar
dterei committed
771
        -- Check that the actual module also defines the thing, and
dterei's avatar
dterei committed
772
        -- then compare the definitions
773
774
      | Just real_thing <- lookupTypeEnv local_type_env name,
        Just boot_thing <- mb_boot_thing
775
      = checkBootDeclM True boot_thing real_thing
776

777
      | otherwise
778
      = addErrTc (missingBootThing True name "defined in")
779
      where
dterei's avatar
dterei committed
780
781
782
783
784
        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
785

786
787
    dfun_names = map getName boot_insts

788
789
    local_export_env :: NameEnv AvailInfo
    local_export_env = availsToNameEnv local_exports
790

791
    check_inst :: ClsInst -> TcM (Maybe (Id, Id))
792
793
794
795
        -- Returns a pair of the boot dfun in terms of the equivalent
        -- real dfun. Delicate (like checkBootDecl) because it depends
        -- on the types lining up precisely even to the ordering of
        -- the type variables in the foralls.
796
    check_inst boot_inst
dterei's avatar
dterei committed
797
        = case [dfun | inst <- local_insts,
dterei's avatar
dterei committed
798
                       let dfun = instanceDFunId inst,
799
800
801
802
803
804
                       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
                          ]
805
806
                     ; addErrTc (instMisMatch True boot_inst)
                     ; return Nothing }
dterei's avatar
dterei committed
807
            (dfun:_) -> return (Just (local_boot_dfun, dfun))
808
                     where
809
                        local_boot_dfun = Id.mkExportedVanillaId boot_dfun_name (idType dfun)
810
811
812
813
814
                           -- 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
815
        where
816
817
818
          boot_dfun      = instanceDFunId boot_inst
          boot_dfun_ty   = idType boot_dfun
          boot_dfun_name = idName boot_dfun
819

Edward Z. Yang's avatar
Edward Z. Yang committed
820
821
-- In general, to perform these checks we have to
-- compare the TyThing from the .hi-boot file to the TyThing
822
823
824
825
826
827
-- 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.

828
829
830
831
832
-- | 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
Edward Z. Yang's avatar
Edward Z. Yang committed
833
  = whenIsJust (checkBootDecl is_boot boot_thing real_thing) $ \ err ->
834
       addErrAt span
835
                (bootMisMatch is_boot err real_thing boot_thing)
836
837
838
839
840
841
842
843
844
  where
    -- Here we use the span of the boot thing or, if it doesn't have a sensible
    -- span, that of the real thing,
    span
      | let span = nameSrcSpan (getName boot_thing)
      , isGoodSrcSpan span
      = span
      | otherwise
      = nameSrcSpan (getName real_thing)
845
846
847
848
849

-- | 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.
Edward Z. Yang's avatar
Edward Z. Yang committed
850
checkBootDecl :: Bool -> TyThing -> TyThing -> Maybe SDoc
851

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

Edward Z. Yang's avatar
Edward Z. Yang committed
857
858
checkBootDecl is_boot (ATyCon tc1) (ATyCon tc2)
  = checkBootTyCon is_boot tc1 tc2
859

Edward Z. Yang's avatar
Edward Z. Yang committed
860
checkBootDecl _ (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _))
batterseapower's avatar
batterseapower committed
861
862
  = pprPanic "checkBootDecl" (ppr dc1)

Edward Z. Yang's avatar
Edward Z. Yang committed
863
checkBootDecl _ _ _ = Just empty -- probably shouldn't happen
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884

-- | 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 plural.
checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc
            -> Maybe SDoc
checkListBy check_fun as bs whats = go [] as bs
  where
    herald = text "The" <+> whats <+> text "do not match"
Austin Seipp's avatar
Austin Seipp committed
885

886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
    go []   [] [] = Nothing
    go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs))
    go docs (x:xs) (y:ys) = case check_fun x y of
      Just doc -> go (doc:docs) xs ys
      Nothing  -> go docs       xs ys
    go _    _  _ = Just (hang (herald <> colon)
                            2 (text "There are different numbers of" <+> whats))

-- | If the test in the first parameter is True, succeed with @Nothing@;
-- otherwise, fail with the given SDoc.
check :: Bool -> SDoc -> Maybe SDoc
check True  _   = Nothing
check False doc = Just doc

-- | A more perspicuous name for @Nothing@, for @checkBootDecl@ and friends.
checkSuccess :: Maybe SDoc
checkSuccess = Nothing
batterseapower's avatar
batterseapower committed
903
904

----------------
Edward Z. Yang's avatar
Edward Z. Yang committed
905
906
checkBootTyCon :: Bool -> TyCon -> TyCon -> Maybe SDoc
checkBootTyCon is_boot tc1 tc2
907
  | not (eqType (tyConKind tc1) (tyConKind tc2))
908
  = Just $ text "The types have different kinds"    -- First off, check the kind
batterseapower's avatar
batterseapower committed
909
910
911

  | Just c1 <- tyConClass_maybe tc1
  , Just c2 <- tyConClass_maybe tc2
912
  , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1)
913
          = classExtraBigSig c1
914
        (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2)
915
          = classExtraBigSig c2
916
  , Just env <- eqVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2
917
  = let
918
       eqSig (id1, def_meth1) (id2, def_meth2)
919
920
921
922
923
924
         = check (name1 == name2)
                 (text "The names" <+> pname1 <+> text "and" <+> pname2 <+>
                  text "are different") `andThenCheck`
           check (eqTypeX env op_ty1 op_ty2)
                 (text "The types of" <+> pname1 <+>
                  text "are different") `andThenCheck`
925
926
927
928
929
930
931
           if is_boot
               then check (eqMaybeBy eqDM def_meth1 def_meth2)
                          (text "The default methods associated with" <+> pname1 <+>
                           text "are different")
               else check (subDM op_ty1 def_meth1 def_meth2)
                          (text "The default methods associated with" <+> pname1 <+>
                           text "are not compatible")