ae3e5ffdd4a06ffe3cb7eec1077a739e237e70db
[ghc.git] / compiler / typecheck / TcRnDriver.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5 \section[TcMovectle]{Typechecking a whole module}
6
7 https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TypeChecker
8 -}
9
10 {-# LANGUAGE CPP, NondecreasingIndentation #-}
11
12 module TcRnDriver (
13 #ifdef GHCI
14 tcRnStmt, tcRnExpr, tcRnType,
15 tcRnImportDecls,
16 tcRnLookupRdrName,
17 getModuleInterface,
18 tcRnDeclsi,
19 isGHCiMonad,
20 runTcInteractive, -- Used by GHC API clients (Trac #8878)
21 #endif
22 tcRnLookupName,
23 tcRnGetInfo,
24 tcRnModule, tcRnModuleTcRnM,
25 tcTopSrcDecls,
26 ) where
27
28 #ifdef GHCI
29 import {-# SOURCE #-} TcSplice ( runQuasi )
30 import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )
31 import IfaceEnv( externaliseName )
32 import TcType ( isUnitTy, isTauTy )
33 import TcHsType
34 import TcMatches
35 import RnTypes
36 import RnExpr
37 import MkId
38 import TidyPgm ( globaliseAndTidyId )
39 import TysWiredIn ( unitTy, mkListTy )
40 import DynamicLoading ( loadPlugins )
41 import Plugins ( tcPlugin )
42 #endif
43
44 import DynFlags
45 import StaticFlags
46 import HsSyn
47 import PrelNames
48 import RdrName
49 import TcHsSyn
50 import TcExpr
51 import TcRnMonad
52 import TcEvidence
53 import PprTyThing( pprTyThing )
54 import Coercion( pprCoAxiom )
55 import FamInst
56 import InstEnv
57 import FamInstEnv
58 import TcAnnotations
59 import TcBinds
60 import HeaderInfo ( mkPrelImports )
61 import TcDefaults
62 import TcEnv
63 import TcRules
64 import TcForeign
65 import TcInstDcls
66 import TcIface
67 import TcMType
68 import MkIface
69 import TcSimplify
70 import TcTyClsDecls
71 import LoadIface
72 import TidyPgm ( mkBootModDetailsTc )
73 import RnNames
74 import RnEnv
75 import RnSource
76 import ErrUtils
77 import Id
78 import IdInfo( IdDetails( VanillaId ) )
79 import VarEnv
80 import Module
81 import UniqFM
82 import Name
83 import NameEnv
84 import NameSet
85 import Avail
86 import TyCon
87 import SrcLoc
88 import HscTypes
89 import ListSetOps
90 import Outputable
91 import ConLike
92 import DataCon
93 import Type
94 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 import Util
103 import Bag
104
105 import Control.Monad
106
107 #include "HsVersions.h"
108
109 {-
110 ************************************************************************
111 * *
112 Typecheck and rename a module
113 * *
114 ************************************************************************
115 -}
116
117 -- | Top level entry point for typechecker and renamer
118 tcRnModule :: HscEnv
119 -> HscSource
120 -> Bool -- True <=> save renamed syntax
121 -> HsParsedModule
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 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
128
129 ; initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $
130 withTcPlugins hsc_env $
131 tcRnModuleTcRnM hsc_env hsc_src parsedModule pair }
132
133 | otherwise
134 = return ((emptyBag, unitBag err_msg), Nothing)
135
136 where
137 err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $
138 text "Module does not have a RealSrcSpan:" <+> ppr this_mod
139
140 this_pkg = thisPackage (hsc_dflags hsc_env)
141
142 pair :: (Module, SrcSpan)
143 pair@(this_mod,_)
144 | Just (L mod_loc mod) <- hsmodName this_module
145 = (mkModule this_pkg mod, mod_loc)
146
147 | otherwise -- 'module M where' is omitted
148 = (mAIN, srcLocSpan (srcSpanStart loc))
149
150
151 -- To be called at the beginning of renaming hsig files.
152 -- If we're processing a signature, load up the RdrEnv
153 -- specified by sig-of so that
154 -- when we process top-level bindings, we pull in the right
155 -- original names. We also need to add in dependencies from
156 -- the implementation (orphans, family instances, packages),
157 -- similar to how rnImportDecl handles things.
158 -- ToDo: Handle SafeHaskell
159 tcRnSignature :: DynFlags -> HscSource -> TcRn TcGblEnv
160 tcRnSignature dflags hsc_src
161 = do { tcg_env <- getGblEnv ;
162 case tcg_sig_of tcg_env of {
163 Just sof
164 | hsc_src /= HsBootFile -> do
165 { modname <- fmap moduleName getModule
166 ; addErr (text "Found -sig-of entry for" <+> ppr modname
167 <+> text "which is not hs-boot." $$
168 text "Try removing" <+> ppr modname <+>
169 text "from -sig-of")
170 ; return tcg_env
171 }
172 | otherwise -> do
173 { sig_iface <- initIfaceTcRn $ loadSysInterface (text "sig-of") sof
174 ; let { gr = mkGlobalRdrEnv
175 (gresFromAvails Nothing (mi_exports sig_iface))
176 ; avails = calculateAvails dflags
177 sig_iface False{- safe -} False{- boot -} }
178 ; return (tcg_env
179 { tcg_impl_rdr_env = Just gr
180 , tcg_imports = tcg_imports tcg_env `plusImportAvails` avails
181 })
182 } ;
183 Nothing -> return tcg_env
184 }
185 }
186
187 checkHsigIface :: HscEnv -> TcGblEnv -> TcRn ()
188 checkHsigIface hsc_env tcg_env
189 = case tcg_impl_rdr_env tcg_env of
190 Just gr -> do { sig_details <- liftIO $ mkBootModDetailsTc hsc_env tcg_env
191 ; checkHsigIface' gr sig_details
192 }
193 Nothing -> return ()
194
195 checkHsigIface' :: GlobalRdrEnv -> ModDetails -> TcRn ()
196 checkHsigIface' gr
197 ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts,
198 md_types = sig_type_env, md_exports = sig_exports}
199 = do { traceTc "checkHsigIface" $ vcat
200 [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ]
201 ; mapM_ check_export sig_exports
202 ; unless (null sig_fam_insts) $
203 panic ("TcRnDriver.checkHsigIface: Cannot handle family " ++
204 "instances in hsig files yet...")
205 ; mapM_ check_inst sig_insts
206 ; failIfErrsM
207 }
208 where
209 check_export sig_avail
210 -- Skip instances, we'll check them later
211 | name `elem` dfun_names = return ()
212 | otherwise = do
213 { -- Lookup local environment only (don't want to accidentally pick
214 -- up the backing copy.) We consult tcg_type_env because we want
215 -- to pick up wired in names too (which get dropped by the iface
216 -- creation process); it's OK for a signature file to mention
217 -- a wired in name.
218 env <- getGblEnv
219 ; case lookupNameEnv (tcg_type_env env) name of
220 Nothing
221 -- All this means is no local definition is available: but we
222 -- could have created the export this way:
223 --
224 -- module ASig(f) where
225 -- import B(f)
226 --
227 -- In this case, we have to just lookup the identifier in
228 -- the backing implementation and make sure it matches.
229 | [GRE { gre_name = name' }]
230 <- lookupGlobalRdrEnv gr (nameOccName name)
231 , name == name' -> return ()
232 -- TODO: Possibly give a different error if the identifier
233 -- is exported, but it's a different original name
234 | otherwise -> addErrAt (nameSrcSpan name)
235 (missingBootThing False name "exported by")
236 Just sig_thing -> do {
237 -- We use tcLookupImported_maybe because we want to EXCLUDE
238 -- tcg_env.
239 ; r <- tcLookupImported_maybe name
240 ; case r of
241 Failed err -> addErr err
242 Succeeded real_thing -> checkBootDeclM False sig_thing real_thing
243 }}
244 where
245 name = availName sig_avail
246
247 dfun_names = map getName sig_insts
248
249 -- In general, for hsig files we can't assume that the implementing
250 -- file actually implemented the instances (they may be reexported
251 -- from elsewhere). Where should we look for the instances? We do
252 -- the same as we would otherwise: consult the EPS. This isn't
253 -- perfect (we might conclude the module exports an instance
254 -- when it doesn't, see #9422), but we will never refuse to compile
255 -- something
256 check_inst :: ClsInst -> TcM ()
257 check_inst sig_inst
258 = do eps <- getEps
259 when (not (memberInstEnv (eps_inst_env eps) sig_inst)) $
260 addErrTc (instMisMatch False sig_inst)
261
262 tcRnModuleTcRnM :: HscEnv
263 -> HscSource
264 -> HsParsedModule
265 -> (Module, SrcSpan)
266 -> TcRn TcGblEnv
267 -- Factored out separately from tcRnModule so that a Core plugin can
268 -- call the type checker directly
269 tcRnModuleTcRnM hsc_env hsc_src
270 (HsParsedModule {
271 hpm_module =
272 (L loc (HsModule maybe_mod export_ies
273 import_decls local_decls mod_deprec
274 maybe_doc_hdr)),
275 hpm_src_files = src_files
276 })
277 (this_mod, prel_imp_loc)
278 = setSrcSpan loc $
279 do { let { dflags = hsc_dflags hsc_env
280 ; explicit_mod_hdr = isJust maybe_mod } ;
281
282 tcg_env <- tcRnSignature dflags hsc_src ;
283 setGblEnv tcg_env $ do {
284
285 -- Load the hi-boot interface for this module, if any
286 -- We do this now so that the boot_names can be passed
287 -- to tcTyAndClassDecls, because the boot_names are
288 -- automatically considered to be loop breakers
289 --
290 -- Do this *after* tcRnImports, so that we know whether
291 -- a module that we import imports us; and hence whether to
292 -- look for a hi-boot file
293 boot_info <- tcHiBootIface hsc_src this_mod ;
294 setGblEnv (tcg_env { tcg_self_boot = boot_info }) $ do {
295
296 -- Deal with imports; first add implicit prelude
297 implicit_prelude <- xoptM Opt_ImplicitPrelude;
298 let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc
299 implicit_prelude import_decls } ;
300
301 whenWOptM Opt_WarnImplicitPrelude $
302 when (notNull prel_imports) $ addWarn (implicitPreludeWarn) ;
303
304 tcg_env <- {-# SCC "tcRnImports" #-}
305 tcRnImports hsc_env (prel_imports ++ import_decls) ;
306
307 -- If the whole module is warned about or deprecated
308 -- (via mod_deprec) record that in tcg_warns. If we do thereby add
309 -- a WarnAll, it will override any subseqent depracations added to tcg_warns
310 let { tcg_env1 = case mod_deprec of
311 Just (L _ txt) -> tcg_env { tcg_warns = WarnAll txt }
312 Nothing -> tcg_env
313 } ;
314
315 setGblEnv tcg_env1 $ do {
316
317 -- Rename and type check the declarations
318 traceRn (text "rn1a") ;
319 tcg_env <- if isHsBoot hsc_src then
320 tcRnHsBootDecls hsc_src local_decls
321 else
322 {-# SCC "tcRnSrcDecls" #-}
323 tcRnSrcDecls explicit_mod_hdr export_ies local_decls ;
324 setGblEnv tcg_env $ do {
325
326 -- Process the export list
327 traceRn (text "rn4a: before exports");
328 tcg_env <- rnExports explicit_mod_hdr export_ies tcg_env ;
329 traceRn (text "rn4b: after exports") ;
330
331 -- Check that main is exported (must be after rnExports)
332 checkMainExported tcg_env ;
333
334 -- Compare the hi-boot iface (if any) with the real thing
335 -- Must be done after processing the exports
336 tcg_env <- checkHiBootIface tcg_env boot_info ;
337
338 -- Compare the hsig tcg_env with the real thing
339 checkHsigIface hsc_env tcg_env ;
340
341 -- Nub out type class instances now that we've checked them,
342 -- if we're compiling an hsig with sig-of.
343 -- See Note [Signature files and type class instances]
344 tcg_env <- (case tcg_sig_of tcg_env of
345 Just _ -> return tcg_env {
346 tcg_inst_env = emptyInstEnv,
347 tcg_fam_inst_env = emptyFamInstEnv,
348 tcg_insts = [],
349 tcg_fam_insts = []
350 }
351 Nothing -> return tcg_env) ;
352
353 -- The new type env is already available to stuff slurped from
354 -- interface files, via TcEnv.updateGlobalTypeEnv
355 -- It's important that this includes the stuff in checkHiBootIface,
356 -- because the latter might add new bindings for boot_dfuns,
357 -- which may be mentioned in imported unfoldings
358
359 -- Don't need to rename the Haddock documentation,
360 -- it's not parsed by GHC anymore.
361 tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ;
362
363 -- Report unused names
364 reportUnusedNames export_ies tcg_env ;
365
366 -- add extra source files to tcg_dependent_files
367 addDependentFiles src_files ;
368
369 -- Dump output and return
370 tcDump tcg_env ;
371 return tcg_env
372 }}}}}
373
374 implicitPreludeWarn :: SDoc
375 implicitPreludeWarn
376 = ptext (sLit "Module `Prelude' implicitly imported")
377
378 {-
379 ************************************************************************
380 * *
381 Import declarations
382 * *
383 ************************************************************************
384 -}
385
386 tcRnImports :: HscEnv -> [LImportDecl RdrName] -> TcM TcGblEnv
387 tcRnImports hsc_env import_decls
388 = do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ;
389
390 ; this_mod <- getModule
391 ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
392 ; dep_mods = imp_dep_mods imports
393
394 -- We want instance declarations from all home-package
395 -- modules below this one, including boot modules, except
396 -- ourselves. The 'except ourselves' is so that we don't
397 -- get the instances from this module's hs-boot file. This
398 -- filtering also ensures that we don't see instances from
399 -- modules batch (@--make@) compiled before this one, but
400 -- which are not below this one.
401 ; want_instances :: ModuleName -> Bool
402 ; want_instances mod = mod `elemUFM` dep_mods
403 && mod /= moduleName this_mod
404 ; (home_insts, home_fam_insts) = hptInstances hsc_env
405 want_instances
406 } ;
407
408 -- Record boot-file info in the EPS, so that it's
409 -- visible to loadHiBootInterface in tcRnSrcDecls,
410 -- and any other incrementally-performed imports
411 ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
412
413 -- Update the gbl env
414 ; updGblEnv ( \ gbl ->
415 gbl {
416 tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env,
417 tcg_imports = tcg_imports gbl `plusImportAvails` imports,
418 tcg_rn_imports = rn_imports,
419 tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,
420 tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
421 home_fam_insts,
422 tcg_hpc = hpc_info
423 }) $ do {
424
425 ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports))
426 -- Fail if there are any errors so far
427 -- The error printing (if needed) takes advantage
428 -- of the tcg_env we have now set
429 -- ; traceIf (text "rdr_env: " <+> ppr rdr_env)
430 ; failIfErrsM
431
432 -- Load any orphan-module and family instance-module
433 -- interfaces, so that their rules and instance decls will be
434 -- found. But filter out a self hs-boot: these instances
435 -- will be checked when we define them locally.
436 ; loadModuleInterfaces (ptext (sLit "Loading orphan modules"))
437 (filter (/= this_mod) (imp_orphs imports))
438
439 -- Check type-family consistency
440 ; traceRn (text "rn1: checking family instance consistency")
441 ; let { dir_imp_mods = moduleEnvKeys
442 . imp_mods
443 $ imports }
444 ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ;
445
446 ; getGblEnv } }
447
448 {-
449 ************************************************************************
450 * *
451 Type-checking the top level of a module
452 * *
453 ************************************************************************
454 -}
455
456 tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all
457 -> Maybe (Located [LIE RdrName]) -- Exports
458 -> [LHsDecl RdrName] -- Declarations
459 -> TcM TcGblEnv
460 -- Returns the variables free in the decls
461 -- Reason: solely to report unused imports and bindings
462 tcRnSrcDecls explicit_mod_hdr exports decls
463 = do { -- Do all the declarations
464 ((tcg_env, tcl_env), lie) <- captureConstraints $
465 do { (tcg_env, tcl_env) <- tc_rn_src_decls decls ;
466 ; tcg_env <- setEnvs (tcg_env, tcl_env) $
467 checkMain explicit_mod_hdr
468 ; return (tcg_env, tcl_env) }
469 ; setEnvs (tcg_env, tcl_env) $ do {
470
471 #ifdef GHCI
472 -- Run all module finalizers
473 let th_modfinalizers_var = tcg_th_modfinalizers tcg_env
474 ; modfinalizers <- readTcRef th_modfinalizers_var
475 ; writeTcRef th_modfinalizers_var []
476 ; mapM_ runQuasi modfinalizers
477 #endif /* GHCI */
478
479 -- wanted constraints from static forms
480 ; stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef
481
482 -- Finish simplifying class constraints
483 --
484 -- simplifyTop deals with constant or ambiguous InstIds.
485 -- How could there be ambiguous ones? They can only arise if a
486 -- top-level decl falls under the monomorphism restriction
487 -- and no subsequent decl instantiates its type.
488 --
489 -- We do this after checkMain, so that we use the type info
490 -- that checkMain adds
491 --
492 -- We do it with both global and local env in scope:
493 -- * the global env exposes the instances to simplifyTop
494 -- * the local env exposes the local Ids to simplifyTop,
495 -- so that we get better error messages (monomorphism restriction)
496 ; new_ev_binds <- {-# SCC "simplifyTop" #-}
497 simplifyTop (andWC stWC lie)
498 ; traceTc "Tc9" empty
499
500 ; failIfErrsM -- Don't zonk if there have been errors
501 -- It's a waste of time; and we may get debug warnings
502 -- about strangely-typed TyCons!
503 ; traceTc "Tc10" empty
504
505 -- Zonk the final code. This must be done last.
506 -- Even simplifyTop may do some unification.
507 -- This pass also warns about missing type signatures
508 ; let { TcGblEnv { tcg_type_env = type_env,
509 tcg_binds = binds,
510 tcg_sigs = sig_ns,
511 tcg_ev_binds = cur_ev_binds,
512 tcg_imp_specs = imp_specs,
513 tcg_rules = rules,
514 tcg_vects = vects,
515 tcg_fords = fords } = tcg_env
516 ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
517
518 ; (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
519 <- {-# SCC "zonkTopDecls" #-}
520 zonkTopDecls all_ev_binds binds exports sig_ns rules vects
521 imp_specs fords ;
522 ; traceTc "Tc11" empty
523
524 ; let { final_type_env = extendTypeEnvWithIds type_env bind_ids
525 ; tcg_env' = tcg_env { tcg_binds = binds',
526 tcg_ev_binds = ev_binds',
527 tcg_imp_specs = imp_specs',
528 tcg_rules = rules',
529 tcg_vects = vects',
530 tcg_fords = fords' } } ;
531
532 ; setGlobalTypeEnv tcg_env' final_type_env
533
534 } }
535
536 tc_rn_src_decls :: [LHsDecl RdrName]
537 -> TcM (TcGblEnv, TcLclEnv)
538 -- Loops around dealing with each top level inter-splice group
539 -- in turn, until it's dealt with the entire module
540 tc_rn_src_decls ds
541 = {-# SCC "tc_rn_src_decls" #-}
542 do { (first_group, group_tail) <- findSplice ds
543 -- If ds is [] we get ([], Nothing)
544
545 -- Deal with decls up to, but not including, the first splice
546 ; (tcg_env, rn_decls) <- rnTopSrcDecls first_group
547 -- rnTopSrcDecls fails if there are any errors
548
549 #ifdef GHCI
550 -- Get TH-generated top-level declarations and make sure they don't
551 -- contain any splices since we don't handle that at the moment
552 ; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv
553 ; th_ds <- readTcRef th_topdecls_var
554 ; writeTcRef th_topdecls_var []
555
556 ; (tcg_env, rn_decls) <-
557 if null th_ds
558 then return (tcg_env, rn_decls)
559 else do { (th_group, th_group_tail) <- findSplice th_ds
560 ; case th_group_tail of
561 { Nothing -> return () ;
562 ; Just (SpliceDecl (L loc _) _, _)
563 -> setSrcSpan loc $
564 addErr (ptext (sLit "Declaration splices are not permitted inside top-level declarations added with addTopDecls"))
565 } ;
566
567 -- Rename TH-generated top-level declarations
568 ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env $
569 rnTopSrcDecls th_group
570
571 -- Dump generated top-level declarations
572 ; let msg = "top-level declarations added with addTopDecls"
573 ; traceSplice $ SpliceInfo { spliceDescription = msg
574 , spliceIsDecl = True
575 , spliceSource = Nothing
576 , spliceGenerated = ppr th_rn_decls }
577
578 ; return (tcg_env, appendGroups rn_decls th_rn_decls)
579 }
580 #endif /* GHCI */
581
582 -- Type check all declarations
583 ; (tcg_env, tcl_env) <- setGblEnv tcg_env $
584 tcTopSrcDecls rn_decls
585
586 -- If there is no splice, we're nearly done
587 ; setEnvs (tcg_env, tcl_env) $
588 case group_tail of
589 { Nothing -> return (tcg_env, tcl_env)
590
591 #ifndef GHCI
592 -- There shouldn't be a splice
593 ; Just (SpliceDecl {}, _) ->
594 failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
595 }
596 #else
597 -- If there's a splice, we must carry on
598 ; Just (SpliceDecl (L _ splice) _, rest_ds) ->
599 do { -- Rename the splice expression, and get its supporting decls
600 (spliced_decls, splice_fvs) <- checkNoErrs (rnTopSpliceDecls splice)
601
602 -- Glue them on the front of the remaining decls and loop
603 ; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
604 tc_rn_src_decls (spliced_decls ++ rest_ds)
605 }
606 }
607 #endif /* GHCI */
608 }
609
610 {-
611 ************************************************************************
612 * *
613 Compiling hs-boot source files, and
614 comparing the hi-boot interface with the real thing
615 * *
616 ************************************************************************
617 -}
618
619 tcRnHsBootDecls :: HscSource -> [LHsDecl RdrName] -> TcM TcGblEnv
620 tcRnHsBootDecls hsc_src decls
621 = do { (first_group, group_tail) <- findSplice decls
622
623 -- Rename the declarations
624 ; (tcg_env, HsGroup {
625 hs_tyclds = tycl_decls,
626 hs_instds = inst_decls,
627 hs_derivds = deriv_decls,
628 hs_fords = for_decls,
629 hs_defds = def_decls,
630 hs_ruleds = rule_decls,
631 hs_vects = vect_decls,
632 hs_annds = _,
633 hs_valds = val_binds }) <- rnTopSrcDecls first_group
634 -- The empty list is for extra dependencies coming from .hs-boot files
635 -- See Note [Extra dependencies from .hs-boot files] in RnSource
636 ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {
637
638
639 -- Check for illegal declarations
640 ; case group_tail of
641 Just (SpliceDecl d _, _) -> badBootDecl hsc_src "splice" d
642 Nothing -> return ()
643 ; mapM_ (badBootDecl hsc_src "foreign") for_decls
644 ; mapM_ (badBootDecl hsc_src "default") def_decls
645 ; mapM_ (badBootDecl hsc_src "rule") rule_decls
646 ; mapM_ (badBootDecl hsc_src "vect") vect_decls
647
648 -- Typecheck type/class/isntance decls
649 ; traceTc "Tc2 (boot)" empty
650 ; (tcg_env, inst_infos, _deriv_binds)
651 <- tcTyClsInstDecls tycl_decls inst_decls deriv_decls
652 ; setGblEnv tcg_env $ do {
653
654 -- Typecheck value declarations
655 ; traceTc "Tc5" empty
656 ; val_ids <- tcHsBootSigs val_binds
657
658 -- Wrap up
659 -- No simplification or zonking to do
660 ; traceTc "Tc7a" empty
661 ; gbl_env <- getGblEnv
662
663 -- Make the final type-env
664 -- Include the dfun_ids so that their type sigs
665 -- are written into the interface file.
666 ; let { type_env0 = tcg_type_env gbl_env
667 ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
668 -- Don't add the dictionaries for non-recursive case, we don't
669 -- actually want to /define/ the instance, just an export list
670 ; type_env2 | Just _ <- tcg_impl_rdr_env gbl_env = type_env1
671 | otherwise = extendTypeEnvWithIds type_env1 dfun_ids
672 ; dfun_ids = map iDFunId inst_infos
673 }
674
675 ; setGlobalTypeEnv gbl_env type_env2
676 }}
677 ; traceTc "boot" (ppr lie); return gbl_env }
678
679 badBootDecl :: HscSource -> String -> Located decl -> TcM ()
680 badBootDecl _hsc_src what (L loc _)
681 = addErrAt loc (char 'A' <+> text what
682 <+> text "declaration is not (currently) allowed in a hs-boot file")
683
684 {-
685 Once we've typechecked the body of the module, we want to compare what
686 we've found (gathered in a TypeEnv) with the hi-boot details (if any).
687 -}
688
689 checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv
690 -- Compare the hi-boot file for this module (if there is one)
691 -- with the type environment we've just come up with
692 -- In the common case where there is no hi-boot file, the list
693 -- of boot_names is empty.
694
695 checkHiBootIface tcg_env boot_info
696 | NoSelfBoot <- boot_info -- Common case
697 = return tcg_env
698
699 | HsBootFile <- tcg_src tcg_env -- Current module is already a hs-boot file!
700 = return tcg_env
701
702 | SelfBoot { sb_mds = boot_details } <- boot_info
703 , TcGblEnv { tcg_binds = binds
704 , tcg_insts = local_insts
705 , tcg_type_env = local_type_env
706 , tcg_exports = local_exports } <- tcg_env
707 = do { dfun_prs <- checkHiBootIface' local_insts local_type_env
708 local_exports boot_details
709 ; let boot_dfuns = map fst dfun_prs
710 dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
711 | (boot_dfun, dfun) <- dfun_prs ]
712 type_env' = extendTypeEnvWithIds local_type_env boot_dfuns
713 tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds }
714
715 ; setGlobalTypeEnv tcg_env' type_env' }
716 -- Update the global type env *including* the knot-tied one
717 -- so that if the source module reads in an interface unfolding
718 -- mentioning one of the dfuns from the boot module, then it
719 -- can "see" that boot dfun. See Trac #4003
720
721 | otherwise = panic "checkHiBootIface: unreachable code"
722
723 checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo]
724 -> ModDetails -> TcM [(Id, Id)]
725 -- Variant which doesn't require a full TcGblEnv; you could get the
726 -- local components from another ModDetails.
727 --
728 -- We return a list of "impedance-matching" bindings for the dfuns
729 -- defined in the hs-boot file, such as
730 -- $fxEqT = $fEqT
731 -- We need these because the module and hi-boot file might differ in
732 -- the name it chose for the dfun.
733
734 checkHiBootIface'
735 local_insts local_type_env local_exports
736 (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
737 md_types = boot_type_env, md_exports = boot_exports })
738 = do { traceTc "checkHiBootIface" $ vcat
739 [ ppr boot_type_env, ppr boot_insts, ppr boot_exports]
740
741 -- Check the exports of the boot module, one by one
742 ; mapM_ check_export boot_exports
743
744 -- Check for no family instances
745 ; unless (null boot_fam_insts) $
746 panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
747 "instances in boot files yet...")
748 -- FIXME: Why? The actual comparison is not hard, but what would
749 -- be the equivalent to the dfun bindings returned for class
750 -- instances? We can't easily equate tycons...
751
752 -- Check instance declarations
753 -- and generate an impedance-matching binding
754 ; mb_dfun_prs <- mapM check_inst boot_insts
755
756 ; failIfErrsM
757
758 ; return (catMaybes mb_dfun_prs) }
759
760 where
761 check_export boot_avail -- boot_avail is exported by the boot iface
762 | name `elem` dfun_names = return ()
763 | isWiredInName name = return () -- No checking for wired-in names. In particular,
764 -- 'error' is handled by a rather gross hack
765 -- (see comments in GHC.Err.hs-boot)
766
767 -- Check that the actual module exports the same thing
768 | not (null missing_names)
769 = addErrAt (nameSrcSpan (head missing_names))
770 (missingBootThing True (head missing_names) "exported by")
771
772 -- If the boot module does not *define* the thing, we are done
773 -- (it simply re-exports it, and names match, so nothing further to do)
774 | isNothing mb_boot_thing = return ()
775
776 -- Check that the actual module also defines the thing, and
777 -- then compare the definitions
778 | Just real_thing <- lookupTypeEnv local_type_env name,
779 Just boot_thing <- mb_boot_thing
780 = checkBootDeclM True boot_thing real_thing
781
782 | otherwise
783 = addErrTc (missingBootThing True name "defined in")
784 where
785 name = availName boot_avail
786 mb_boot_thing = lookupTypeEnv boot_type_env name
787 missing_names = case lookupNameEnv local_export_env name of
788 Nothing -> [name]
789 Just avail -> availNames boot_avail `minusList` availNames avail
790
791 dfun_names = map getName boot_insts
792
793 local_export_env :: NameEnv AvailInfo
794 local_export_env = availsToNameEnv local_exports
795
796 check_inst :: ClsInst -> TcM (Maybe (Id, Id))
797 -- Returns a pair of the boot dfun in terms of the equivalent real dfun
798 check_inst boot_inst
799 = case [dfun | inst <- local_insts,
800 let dfun = instanceDFunId inst,
801 idType dfun `eqType` boot_dfun_ty ] of
802 [] -> do { traceTc "check_inst" $ vcat
803 [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts)
804 , text "boot_inst" <+> ppr boot_inst
805 , text "boot_dfun_ty" <+> ppr boot_dfun_ty
806 ]
807 ; addErrTc (instMisMatch True boot_inst); return Nothing }
808 (dfun:_) -> return (Just (local_boot_dfun, dfun))
809 where
810 local_boot_dfun = Id.mkExportedLocalId VanillaId boot_dfun_name (idType dfun)
811 -- Name from the /boot-file/ ClsInst, but type from the dfun
812 -- defined in /this module/. That ensures that the TyCon etc
813 -- inside the type are the ones defined in this module, not
814 -- the ones gotten from the hi-boot file, which may have
815 -- a lot less info (Trac #T8743, comment:10).
816 where
817 boot_dfun = instanceDFunId boot_inst
818 boot_dfun_ty = idType boot_dfun
819 boot_dfun_name = idName boot_dfun
820
821 -- This has to compare the TyThing from the .hi-boot file to the TyThing
822 -- in the current source file. We must be careful to allow alpha-renaming
823 -- where appropriate, and also the boot declaration is allowed to omit
824 -- constructors and class methods.
825 --
826 -- See rnfail055 for a good test of this stuff.
827
828 -- | Compares two things for equivalence between boot-file and normal code,
829 -- reporting an error if they don't match up.
830 checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig)
831 -> TyThing -> TyThing -> TcM ()
832 checkBootDeclM is_boot boot_thing real_thing
833 = whenIsJust (checkBootDecl boot_thing real_thing) $ \ err ->
834 addErrAt (nameSrcSpan (getName boot_thing))
835 (bootMisMatch is_boot err real_thing boot_thing)
836
837 -- | Compares the two things for equivalence between boot-file and normal
838 -- code. Returns @Nothing@ on success or @Just "some helpful info for user"@
839 -- failure. If the difference will be apparent to the user, @Just empty@ is
840 -- perfectly suitable.
841 checkBootDecl :: TyThing -> TyThing -> Maybe SDoc
842
843 checkBootDecl (AnId id1) (AnId id2)
844 = ASSERT(id1 == id2)
845 check (idType id1 `eqType` idType id2)
846 (text "The two types are different")
847
848 checkBootDecl (ATyCon tc1) (ATyCon tc2)
849 = checkBootTyCon tc1 tc2
850
851 checkBootDecl (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _))
852 = pprPanic "checkBootDecl" (ppr dc1)
853
854 checkBootDecl _ _ = Just empty -- probably shouldn't happen
855
856 -- | Combines two potential error messages
857 andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc
858 Nothing `andThenCheck` msg = msg
859 msg `andThenCheck` Nothing = msg
860 Just d1 `andThenCheck` Just d2 = Just (d1 $$ d2)
861 infixr 0 `andThenCheck`
862
863 -- | If the test in the first parameter is True, succeed with @Nothing@;
864 -- otherwise, return the provided check
865 checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc
866 checkUnless True _ = Nothing
867 checkUnless False k = k
868
869 -- | Run the check provided for every pair of elements in the lists.
870 -- The provided SDoc should name the element type, in the plural.
871 checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc
872 -> Maybe SDoc
873 checkListBy check_fun as bs whats = go [] as bs
874 where
875 herald = text "The" <+> whats <+> text "do not match"
876
877 go [] [] [] = Nothing
878 go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs))
879 go docs (x:xs) (y:ys) = case check_fun x y of
880 Just doc -> go (doc:docs) xs ys
881 Nothing -> go docs xs ys
882 go _ _ _ = Just (hang (herald <> colon)
883 2 (text "There are different numbers of" <+> whats))
884
885 -- | If the test in the first parameter is True, succeed with @Nothing@;
886 -- otherwise, fail with the given SDoc.
887 check :: Bool -> SDoc -> Maybe SDoc
888 check True _ = Nothing
889 check False doc = Just doc
890
891 -- | A more perspicuous name for @Nothing@, for @checkBootDecl@ and friends.
892 checkSuccess :: Maybe SDoc
893 checkSuccess = Nothing
894
895 ----------------
896 checkBootTyCon :: TyCon -> TyCon -> Maybe SDoc
897 checkBootTyCon tc1 tc2
898 | not (eqKind (tyConKind tc1) (tyConKind tc2))
899 = Just $ text "The types have different kinds" -- First off, check the kind
900
901 | Just c1 <- tyConClass_maybe tc1
902 , Just c2 <- tyConClass_maybe tc2
903 , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1)
904 = classExtraBigSig c1
905 (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2)
906 = classExtraBigSig c2
907 , Just env <- eqTyVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2
908 = let
909 eqSig (id1, def_meth1) (id2, def_meth2)
910 = check (name1 == name2)
911 (text "The names" <+> pname1 <+> text "and" <+> pname2 <+>
912 text "are different") `andThenCheck`
913 check (eqTypeX env op_ty1 op_ty2)
914 (text "The types of" <+> pname1 <+>
915 text "are different") `andThenCheck`
916 check (def_meth1 == def_meth2)
917 (text "The default methods associated with" <+> pname1 <+>
918 text "are different")
919 where
920 name1 = idName id1
921 name2 = idName id2
922 pname1 = quotes (ppr name1)
923 pname2 = quotes (ppr name2)
924 (_, rho_ty1) = splitForAllTys (idType id1)
925 op_ty1 = funResultTy rho_ty1
926 (_, rho_ty2) = splitForAllTys (idType id2)
927 op_ty2 = funResultTy rho_ty2
928
929 eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2)
930 = checkBootTyCon tc1 tc2 `andThenCheck`
931 check (eqATDef def_ats1 def_ats2)
932 (text "The associated type defaults differ")
933
934 -- Ignore the location of the defaults
935 eqATDef Nothing Nothing = True
936 eqATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2
937 eqATDef _ _ = False
938
939 eqFD (as1,bs1) (as2,bs2) =
940 eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
941 eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
942 in
943 check (roles1 == roles2) roles_msg `andThenCheck`
944 -- Checks kind of class
945 check (eqListBy eqFD clas_fds1 clas_fds2)
946 (text "The functional dependencies do not match") `andThenCheck`
947 checkUnless (null sc_theta1 && null op_stuff1 && null ats1) $
948 -- Above tests for an "abstract" class
949 check (eqListBy (eqPredX env) sc_theta1 sc_theta2)
950 (text "The class constraints do not match") `andThenCheck`
951 checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck`
952 checkListBy eqAT ats1 ats2 (text "associated types")
953
954 | Just syn_rhs1 <- synTyConRhs_maybe tc1
955 , Just syn_rhs2 <- synTyConRhs_maybe tc2
956 , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
957 = ASSERT(tc1 == tc2)
958 check (roles1 == roles2) roles_msg `andThenCheck`
959 check (eqTypeX env syn_rhs1 syn_rhs2) empty -- nothing interesting to say
960
961 | Just fam_flav1 <- famTyConFlav_maybe tc1
962 , Just fam_flav2 <- famTyConFlav_maybe tc2
963 = ASSERT(tc1 == tc2)
964 let eqFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon = True
965 eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True
966 eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True
967 eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2)
968 = eqClosedFamilyAx ax1 ax2
969 eqFamFlav (BuiltInSynFamTyCon _) (BuiltInSynFamTyCon _) = tc1 == tc2
970 eqFamFlav _ _ = False
971 injInfo1 = familyTyConInjectivityInfo tc1
972 injInfo2 = familyTyConInjectivityInfo tc2
973 in
974 -- check equality of roles, family flavours and injectivity annotations
975 check (roles1 == roles2) roles_msg `andThenCheck`
976 check (eqFamFlav fam_flav1 fam_flav2) empty `andThenCheck`
977 check (injInfo1 == injInfo2) empty
978
979 | isAlgTyCon tc1 && isAlgTyCon tc2
980 , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
981 = ASSERT(tc1 == tc2)
982 check (roles1 == roles2) roles_msg `andThenCheck`
983 check (eqListBy (eqPredX env)
984 (tyConStupidTheta tc1) (tyConStupidTheta tc2))
985 (text "The datatype contexts do not match") `andThenCheck`
986 eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2)
987
988 | otherwise = Just empty -- two very different types -- should be obvious
989 where
990 roles1 = tyConRoles tc1
991 roles2 = tyConRoles tc2
992 roles_msg = text "The roles do not match." $$
993 (text "Roles on abstract types default to" <+>
994 quotes (text "representational") <+> text "in boot files.")
995
996 eqAlgRhs tc (AbstractTyCon dis1) rhs2
997 | dis1 = check (isGenInjAlgRhs rhs2) --Check compatibility
998 (text "The natures of the declarations for" <+>
999 quotes (ppr tc) <+> text "are different")
1000 | otherwise = checkSuccess
1001 eqAlgRhs _ DataFamilyTyCon{} DataFamilyTyCon{} = checkSuccess
1002 eqAlgRhs _ tc1@DataTyCon{} tc2@DataTyCon{} =
1003 checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors")
1004 eqAlgRhs _ tc1@NewTyCon{} tc2@NewTyCon{} =
1005 eqCon (data_con tc1) (data_con tc2)
1006 eqAlgRhs _ _ _ = Just (text "Cannot match a" <+> quotes (text "data") <+>
1007 text "definition with a" <+> quotes (text "newtype") <+>
1008 text "definition")
1009
1010 eqCon c1 c2
1011 = check (name1 == name2)
1012 (text "The names" <+> pname1 <+> text "and" <+> pname2 <+>
1013 text "differ") `andThenCheck`
1014 check (dataConIsInfix c1 == dataConIsInfix c2)
1015 (text "The fixities of" <+> pname1 <+>
1016 text "differ") `andThenCheck`
1017 check (eqListBy eqHsBang (dataConImplBangs c1) (dataConImplBangs c2))
1018 (text "The strictness annotations for" <+> pname1 <+>
1019 text "differ") `andThenCheck`
1020 check (map flSelector (dataConFieldLabels c1) == map flSelector (dataConFieldLabels c2))
1021 (text "The record label lists for" <+> pname1 <+>
1022 text "differ") `andThenCheck`
1023 check (eqType (dataConUserType c1) (dataConUserType c2))
1024 (text "The types for" <+> pname1 <+> text "differ")
1025 where
1026 name1 = dataConName c1
1027 name2 = dataConName c2
1028 pname1 = quotes (ppr name1)
1029 pname2 = quotes (ppr name2)
1030
1031 eqClosedFamilyAx Nothing Nothing = True
1032 eqClosedFamilyAx Nothing (Just _) = False
1033 eqClosedFamilyAx (Just _) Nothing = False
1034 eqClosedFamilyAx (Just (CoAxiom { co_ax_branches = branches1 }))
1035 (Just (CoAxiom { co_ax_branches = branches2 }))
1036 = numBranches branches1 == numBranches branches2
1037 && (and $ zipWith eqClosedFamilyBranch branch_list1 branch_list2)
1038 where
1039 branch_list1 = fromBranches branches1
1040 branch_list2 = fromBranches branches2
1041
1042 eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_lhs = lhs1, cab_rhs = rhs1 })
1043 (CoAxBranch { cab_tvs = tvs2, cab_lhs = lhs2, cab_rhs = rhs2 })
1044 | Just env <- eqTyVarBndrs emptyRnEnv2 tvs1 tvs2
1045 = eqListBy (eqTypeX env) lhs1 lhs2 &&
1046 eqTypeX env rhs1 rhs2
1047
1048 | otherwise = False
1049
1050 emptyRnEnv2 :: RnEnv2
1051 emptyRnEnv2 = mkRnEnv2 emptyInScopeSet
1052
1053 ----------------
1054 missingBootThing :: Bool -> Name -> String -> SDoc
1055 missingBootThing is_boot name what
1056 = quotes (ppr name) <+> ptext (sLit "is exported by the")
1057 <+> (if is_boot then ptext (sLit "hs-boot") else ptext (sLit "signature"))
1058 <+> ptext (sLit "file, but not")
1059 <+> text what <+> ptext (sLit "the module")
1060
1061 bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc
1062 bootMisMatch is_boot extra_info real_thing boot_thing
1063 = vcat [ppr real_thing <+>
1064 ptext (sLit "has conflicting definitions in the module"),
1065 ptext (sLit "and its") <+>
1066 (if is_boot then ptext (sLit "hs-boot file")
1067 else ptext (sLit "signature file")),
1068 ptext (sLit "Main module:") <+> PprTyThing.pprTyThing real_thing,
1069 (if is_boot
1070 then ptext (sLit "Boot file: ")
1071 else ptext (sLit "Signature file: "))
1072 <+> PprTyThing.pprTyThing boot_thing,
1073 extra_info]
1074
1075 instMisMatch :: Bool -> ClsInst -> SDoc
1076 instMisMatch is_boot inst
1077 = hang (ppr inst)
1078 2 (ptext (sLit "is defined in the") <+>
1079 (if is_boot then ptext (sLit "hs-boot") else ptext (sLit "signature"))
1080 <+> ptext (sLit "file, but not in the module itself"))
1081
1082 {-
1083 ************************************************************************
1084 * *
1085 Type-checking the top level of a module (continued)
1086 * *
1087 ************************************************************************
1088 -}
1089
1090 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
1091 -- Fails if there are any errors
1092 rnTopSrcDecls group
1093 = do { -- Rename the source decls
1094 traceRn (text "rn12") ;
1095 (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
1096 traceRn (text "rn13") ;
1097
1098 -- save the renamed syntax, if we want it
1099 let { tcg_env'
1100 | Just grp <- tcg_rn_decls tcg_env
1101 = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
1102 | otherwise
1103 = tcg_env };
1104
1105 -- Dump trace of renaming part
1106 rnDump (ppr rn_decls) ;
1107 return (tcg_env', rn_decls)
1108 }
1109
1110 tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
1111 tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
1112 hs_instds = inst_decls,
1113 hs_derivds = deriv_decls,
1114 hs_fords = foreign_decls,
1115 hs_defds = default_decls,
1116 hs_annds = annotation_decls,
1117 hs_ruleds = rule_decls,
1118 hs_vects = vect_decls,
1119 hs_valds = val_binds })
1120 = do { -- Type-check the type and class decls, and all imported decls
1121 -- The latter come in via tycl_decls
1122 traceTc "Tc2 (src)" empty ;
1123
1124 -- Source-language instances, including derivings,
1125 -- and import the supporting declarations
1126 traceTc "Tc3" empty ;
1127 (tcg_env, inst_infos, deriv_binds)
1128 <- tcTyClsInstDecls tycl_decls inst_decls deriv_decls ;
1129 setGblEnv tcg_env $ do {
1130
1131 -- Generate Applicative/Monad proposal (AMP) warnings
1132 traceTc "Tc3b" empty ;
1133
1134 -- Foreign import declarations next.
1135 traceTc "Tc4" empty ;
1136 (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ;
1137 tcExtendGlobalValEnv fi_ids $ do {
1138
1139 -- Default declarations
1140 traceTc "Tc4a" empty ;
1141 default_tys <- tcDefaults default_decls ;
1142 updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
1143
1144 -- Now GHC-generated derived bindings, generics, and selectors
1145 -- Do not generate warnings from compiler-generated code;
1146 -- hence the use of discardWarnings
1147 tc_envs <- discardWarnings (tcTopBinds deriv_binds) ;
1148 setEnvs tc_envs $ do {
1149
1150 -- Value declarations next
1151 traceTc "Tc5" empty ;
1152 tc_envs@(tcg_env, tcl_env) <- tcTopBinds val_binds;
1153 setEnvs tc_envs $ do { -- Environment doesn't change now
1154
1155 -- Second pass over class and instance declarations,
1156 -- now using the kind-checked decls
1157 traceTc "Tc6" empty ;
1158 inst_binds <- tcInstDecls2 (tyClGroupConcat tycl_decls) inst_infos ;
1159
1160 -- Foreign exports
1161 traceTc "Tc7" empty ;
1162 (foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ;
1163
1164 -- Annotations
1165 annotations <- tcAnnotations annotation_decls ;
1166
1167 -- Rules
1168 rules <- tcRules rule_decls ;
1169
1170 -- Vectorisation declarations
1171 vects <- tcVectDecls vect_decls ;
1172
1173 -- Wrap up
1174 traceTc "Tc7a" empty ;
1175 let { all_binds = inst_binds `unionBags`
1176 foe_binds
1177
1178 ; fo_gres = fi_gres `unionBags` foe_gres
1179 ; fo_fvs = foldrBag (\gre fvs -> fvs `addOneFV` gre_name gre)
1180 emptyFVs fo_gres
1181
1182 ; sig_names = mkNameSet (collectHsValBinders val_binds)
1183 `minusNameSet` getTypeSigNames val_binds
1184
1185 -- Extend the GblEnv with the (as yet un-zonked)
1186 -- bindings, rules, foreign decls
1187 ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds
1188 , tcg_sigs = tcg_sigs tcg_env `unionNameSet` sig_names
1189 , tcg_rules = tcg_rules tcg_env
1190 ++ flattenRuleDecls rules
1191 , tcg_vects = tcg_vects tcg_env ++ vects
1192 , tcg_anns = tcg_anns tcg_env ++ annotations
1193 , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations
1194 , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls
1195 , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ;
1196 -- tcg_dus: see Note [Newtype constructor usage in foreign declarations]
1197
1198 -- See Note [Newtype constructor usage in foreign declarations]
1199 addUsedGREs (bagToList fo_gres) ;
1200
1201 return (tcg_env', tcl_env)
1202 }}}}}}
1203
1204 ---------------------------
1205 tcTyClsInstDecls :: [TyClGroup Name]
1206 -> [LInstDecl Name]
1207 -> [LDerivDecl Name]
1208 -> TcM (TcGblEnv, -- The full inst env
1209 [InstInfo Name], -- Source-code instance decls to process;
1210 -- contains all dfuns for this module
1211 HsValBinds Name) -- Supporting bindings for derived instances
1212
1213 tcTyClsInstDecls tycl_decls inst_decls deriv_decls
1214 = tcExtendKindEnv2 [ (con, APromotionErr FamDataConPE)
1215 | lid <- inst_decls, con <- get_cons lid ] $
1216 -- Note [AFamDataCon: not promoting data family constructors]
1217 do { tcg_env <- tcTyAndClassDecls tycl_decls ;
1218 ; setGblEnv tcg_env $
1219 tcInstDecls1 tycl_decls inst_decls deriv_decls }
1220 where
1221 -- get_cons extracts the *constructor* bindings of the declaration
1222 get_cons :: LInstDecl Name -> [Name]
1223 get_cons (L _ (TyFamInstD {})) = []
1224 get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid
1225 get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))
1226 = concatMap (get_fi_cons . unLoc) fids
1227
1228 get_fi_cons :: DataFamInstDecl Name -> [Name]
1229 get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } })
1230 = map unLoc $ concatMap (con_names . unLoc) cons
1231
1232 {-
1233 Note [AFamDataCon: not promoting data family constructors]
1234 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1235 Consider
1236 data family T a
1237 data instance T Int = MkT
1238 data Proxy (a :: k)
1239 data S = MkS (Proxy 'MkT)
1240
1241 Is it ok to use the promoted data family instance constructor 'MkT' in
1242 the data declaration for S? No, we don't allow this. It *might* make
1243 sense, but at least it would mean that we'd have to interleave
1244 typechecking instances and data types, whereas at present we do data
1245 types *then* instances.
1246
1247 So to check for this we put in the TcLclEnv a binding for all the family
1248 constructors, bound to AFamDataCon, so that if we trip over 'MkT' when
1249 type checking 'S' we'll produce a decent error message.
1250
1251
1252 ************************************************************************
1253 * *
1254 Checking for 'main'
1255 * *
1256 ************************************************************************
1257 -}
1258
1259 checkMain :: Bool -- False => no 'module M(..) where' header at all
1260 -> TcM TcGblEnv
1261 -- If we are in module Main, check that 'main' is defined.
1262 checkMain explicit_mod_hdr
1263 = do { dflags <- getDynFlags
1264 ; tcg_env <- getGblEnv
1265 ; check_main dflags tcg_env explicit_mod_hdr }
1266
1267 check_main :: DynFlags -> TcGblEnv -> Bool -> TcM TcGblEnv
1268 check_main dflags tcg_env explicit_mod_hdr
1269 | mod /= main_mod
1270 = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >>
1271 return tcg_env
1272
1273 | otherwise
1274 = do { mb_main <- lookupGlobalOccRn_maybe main_fn
1275 -- Check that 'main' is in scope
1276 -- It might be imported from another module!
1277 ; case mb_main of {
1278 Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn)
1279 ; complain_no_main
1280 ; return tcg_env } ;
1281 Just main_name -> do
1282
1283 { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn)
1284 ; let loc = srcLocSpan (getSrcLoc main_name)
1285 ; ioTyCon <- tcLookupTyCon ioTyConName
1286 ; res_ty <- newFlexiTyVarTy liftedTypeKind
1287 ; main_expr
1288 <- addErrCtxt mainCtxt $
1289 tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty])
1290
1291 -- See Note [Root-main Id]
1292 -- Construct the binding
1293 -- :Main.main :: IO res_ty = runMainIO res_ty main
1294 ; run_main_id <- tcLookupId runMainIOName
1295 ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN
1296 (mkVarOccFS (fsLit "main"))
1297 (getSrcSpan main_name)
1298 ; root_main_id = Id.mkExportedLocalId VanillaId root_main_name
1299 (mkTyConApp ioTyCon [res_ty])
1300 ; co = mkWpTyApps [res_ty]
1301 ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
1302 ; main_bind = mkVarBind root_main_id rhs }
1303
1304 ; return (tcg_env { tcg_main = Just main_name,
1305 tcg_binds = tcg_binds tcg_env
1306 `snocBag` main_bind,
1307 tcg_dus = tcg_dus tcg_env
1308 `plusDU` usesOnly (unitFV main_name)
1309 -- Record the use of 'main', so that we don't
1310 -- complain about it being defined but not used
1311 })
1312 }}}
1313 where
1314 mod = tcg_mod tcg_env
1315 main_mod = mainModIs dflags
1316 main_fn = getMainFun dflags
1317 interactive = ghcLink dflags == LinkInMemory
1318
1319 complain_no_main = checkTc (interactive && not explicit_mod_hdr) noMainMsg
1320 -- In interactive mode, without an explicit module header, don't
1321 -- worry about the absence of 'main'.
1322 -- In other modes, fail altogether, so that we don't go on
1323 -- and complain a second time when processing the export list.
1324
1325 mainCtxt = ptext (sLit "When checking the type of the") <+> pp_main_fn
1326 noMainMsg = ptext (sLit "The") <+> pp_main_fn
1327 <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod)
1328 pp_main_fn = ppMainFn main_fn
1329
1330 -- | Get the unqualified name of the function to use as the \"main\" for the main module.
1331 -- Either returns the default name or the one configured on the command line with -main-is
1332 getMainFun :: DynFlags -> RdrName
1333 getMainFun dflags = case mainFunIs dflags of
1334 Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn))
1335 Nothing -> main_RDR_Unqual
1336
1337 -- If we are in module Main, check that 'main' is exported.
1338 checkMainExported :: TcGblEnv -> TcM ()
1339 checkMainExported tcg_env
1340 = case tcg_main tcg_env of
1341 Nothing -> return () -- not the main module
1342 Just main_name ->
1343 do { dflags <- getDynFlags
1344 ; let main_mod = mainModIs dflags
1345 ; checkTc (main_name `elem` concatMap availNames (tcg_exports tcg_env)) $
1346 ptext (sLit "The") <+> ppMainFn (nameRdrName main_name) <+>
1347 ptext (sLit "is not exported by module") <+> quotes (ppr main_mod) }
1348
1349 ppMainFn :: RdrName -> SDoc
1350 ppMainFn main_fn
1351 | rdrNameOcc main_fn == mainOcc
1352 = ptext (sLit "IO action") <+> quotes (ppr main_fn)
1353 | otherwise
1354 = ptext (sLit "main IO action") <+> quotes (ppr main_fn)
1355
1356 mainOcc :: OccName
1357 mainOcc = mkVarOccFS (fsLit "main")
1358
1359 {-
1360 Note [Root-main Id]
1361 ~~~~~~~~~~~~~~~~~~~
1362 The function that the RTS invokes is always :Main.main, which we call
1363 root_main_id. (Because GHC allows the user to have a module not
1364 called Main as the main module, we can't rely on the main function
1365 being called "Main.main". That's why root_main_id has a fixed module
1366 ":Main".)
1367
1368 This is unusual: it's a LocalId whose Name has a Module from another
1369 module. Tiresomely, we must filter it out again in MkIface, les we
1370 get two defns for 'main' in the interface file!
1371
1372
1373 *********************************************************
1374 * *
1375 GHCi stuff
1376 * *
1377 *********************************************************
1378 -}
1379
1380 runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a)
1381 -- Initialise the tcg_inst_env with instances from all home modules.
1382 -- This mimics the more selective call to hptInstances in tcRnImports
1383 runTcInteractive hsc_env thing_inside
1384 = initTcInteractive hsc_env $ withTcPlugins hsc_env $
1385 do { traceTc "setInteractiveContext" $
1386 vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))
1387 , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts)
1388 , text "ic_rn_gbl_env (LocalDef)" <+>
1389 vcat (map ppr [ local_gres | gres <- occEnvElts (ic_rn_gbl_env icxt)
1390 , let local_gres = filter isLocalGRE gres
1391 , not (null local_gres) ]) ]
1392 ; let getOrphans m = fmap (\iface -> mi_module iface
1393 : dep_orphs (mi_deps iface))
1394 (loadSrcInterface (text "runTcInteractive") m
1395 False Nothing)
1396 ; orphs <- fmap concat . forM (ic_imports icxt) $ \i ->
1397 case i of
1398 IIModule n -> getOrphans n
1399 IIDecl i -> getOrphans (unLoc (ideclName i))
1400 ; let imports = emptyImportAvails {
1401 imp_orphs = orphs
1402 }
1403 ; (gbl_env, lcl_env) <- getEnvs
1404 ; let gbl_env' = gbl_env {
1405 tcg_rdr_env = ic_rn_gbl_env icxt
1406 , tcg_type_env = type_env
1407 , tcg_inst_env = extendInstEnvList
1408 (extendInstEnvList (tcg_inst_env gbl_env) ic_insts)
1409 home_insts
1410 , tcg_fam_inst_env = extendFamInstEnvList
1411 (extendFamInstEnvList (tcg_fam_inst_env gbl_env)
1412 ic_finsts)
1413 home_fam_insts
1414 , tcg_field_env = mkNameEnv con_fields
1415 -- setting tcg_field_env is necessary
1416 -- to make RecordWildCards work (test: ghci049)
1417 , tcg_fix_env = ic_fix_env icxt
1418 , tcg_default = ic_default icxt
1419 -- must calculate imp_orphs of the ImportAvails
1420 -- so that instance visibility is done correctly
1421 , tcg_imports = imports
1422 }
1423
1424 ; lcl_env' <- tcExtendLocalTypeEnv lcl_env lcl_ids
1425 ; setEnvs (gbl_env', lcl_env') thing_inside }
1426 where
1427 (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True)
1428
1429 icxt = hsc_IC hsc_env
1430 (ic_insts, ic_finsts) = ic_instances icxt
1431 (lcl_ids, top_ty_things) = partitionWith is_closed (ic_tythings icxt)
1432
1433 is_closed :: TyThing -> Either (Name, TcTyThing) TyThing
1434 -- Put Ids with free type variables (always RuntimeUnks)
1435 -- in the *local* type environment
1436 -- See Note [Initialising the type environment for GHCi]
1437 is_closed thing
1438 | AnId id <- thing
1439 , NotTopLevel <- isClosedLetBndr id
1440 = Left (idName id, ATcId { tct_id = id, tct_closed = NotTopLevel })
1441 | otherwise
1442 = Right thing
1443
1444 type_env1 = mkTypeEnvWithImplicits top_ty_things
1445 type_env = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts)
1446 -- Putting the dfuns in the type_env
1447 -- is just to keep Core Lint happy
1448
1449 con_fields = [ (dataConName c, dataConFieldLabels c)
1450 | ATyCon t <- top_ty_things
1451 , c <- tyConDataCons t ]
1452
1453
1454 {- Note [Initialising the type environment for GHCi]
1455 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1456 Most of the the Ids in ic_things, defined by the user in 'let' stmts,
1457 have closed types. E.g.
1458 ghci> let foo x y = x && not y
1459
1460 However the GHCi debugger creates top-level bindings for Ids whose
1461 types have free RuntimeUnk skolem variables, standing for unknown
1462 types. If we don't register these free TyVars as global TyVars then
1463 the typechecker will try to quantify over them and fall over in
1464 zonkQuantifiedTyVar. so we must add any free TyVars to the
1465 typechecker's global TyVar set. That is most conveniently by using
1466 tcExtendLocalTypeEnv, which automatically extends the global TyVar
1467 set.
1468
1469 We do this by splitting out the Ids with open types, using 'is_closed'
1470 to do the partition. The top-level things go in the global TypeEnv;
1471 the open, NotTopLevel, Ids, with free RuntimeUnk tyvars, go in the
1472 local TypeEnv.
1473
1474 Note that we don't extend the local RdrEnv (tcl_rdr); all the in-scope
1475 things are already in the interactive context's GlobalRdrEnv.
1476 Extending the local RdrEnv isn't terrible, but it means there is an
1477 entry for the same Name in both global and local RdrEnvs, and that
1478 lead to duplicate "perhaps you meant..." suggestions (e.g. T5564).
1479
1480 We don't bother with the tcl_th_bndrs environment either.
1481 -}
1482
1483 #ifdef GHCI
1484 -- | The returned [Id] is the list of new Ids bound by this statement. It can
1485 -- be used to extend the InteractiveContext via extendInteractiveContext.
1486 --
1487 -- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound
1488 -- values, coerced to ().
1489 tcRnStmt :: HscEnv -> GhciLStmt RdrName
1490 -> IO (Messages, Maybe ([Id], LHsExpr Id, FixityEnv))
1491 tcRnStmt hsc_env rdr_stmt
1492 = runTcInteractive hsc_env $ do {
1493
1494 -- The real work is done here
1495 ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ;
1496 zonked_expr <- zonkTopLExpr tc_expr ;
1497 zonked_ids <- zonkTopBndrs bound_ids ;
1498
1499 -- None of the Ids should be of unboxed type, because we
1500 -- cast them all to HValues in the end!
1501 mapM_ bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
1502
1503 traceTc "tcs 1" empty ;
1504 this_mod <- getModule ;
1505 global_ids <- mapM (externaliseAndTidyId this_mod) zonked_ids ;
1506 -- Note [Interactively-bound Ids in GHCi] in HscTypes
1507
1508 {- ---------------------------------------------
1509 At one stage I removed any shadowed bindings from the type_env;
1510 they are inaccessible but might, I suppose, cause a space leak if we leave them there.
1511 However, with Template Haskell they aren't necessarily inaccessible. Consider this
1512 GHCi session
1513 Prelude> let f n = n * 2 :: Int
1514 Prelude> fName <- runQ [| f |]
1515 Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
1516 14
1517 Prelude> let f n = n * 3 :: Int
1518 Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
1519 In the last line we use 'fName', which resolves to the *first* 'f'
1520 in scope. If we delete it from the type env, GHCi crashes because
1521 it doesn't expect that.
1522
1523 Hence this code is commented out
1524
1525 -------------------------------------------------- -}
1526
1527 traceOptTcRn Opt_D_dump_tc
1528 (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
1529 text "Typechecked expr" <+> ppr zonked_expr]) ;
1530
1531 return (global_ids, zonked_expr, fix_env)
1532 }
1533 where
1534 bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"),
1535 nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
1536
1537 {-
1538 --------------------------------------------------------------------------
1539 Typechecking Stmts in GHCi
1540
1541 Here is the grand plan, implemented in tcUserStmt
1542
1543 What you type The IO [HValue] that hscStmt returns
1544 ------------- ------------------------------------
1545 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
1546 bindings: [x,y,...]
1547
1548 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
1549 bindings: [x,y,...]
1550
1551 expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it]
1552 [NB: result not printed] bindings: [it]
1553
1554 expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it]
1555 result showable) bindings: [it]
1556
1557 expr (of non-IO type,
1558 result not showable) ==> error
1559 -}
1560
1561 -- | A plan is an attempt to lift some code into the IO monad.
1562 type PlanResult = ([Id], LHsExpr Id)
1563 type Plan = TcM PlanResult
1564
1565 -- | Try the plans in order. If one fails (by raising an exn), try the next.
1566 -- If one succeeds, take it.
1567 runPlans :: [Plan] -> TcM PlanResult
1568 runPlans [] = panic "runPlans"
1569 runPlans [p] = p
1570 runPlans (p:ps) = tryTcLIE_ (runPlans ps) p
1571
1572 -- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the
1573 -- GHCi 'environment'.
1574 --
1575 -- By 'lift' and 'environment we mean that the code is changed to
1576 -- execute properly in an IO monad. See Note [Interactively-bound Ids
1577 -- in GHCi] in HscTypes for more details. We do this lifting by trying
1578 -- different ways ('plans') of lifting the code into the IO monad and
1579 -- type checking each plan until one succeeds.
1580 tcUserStmt :: GhciLStmt RdrName -> TcM (PlanResult, FixityEnv)
1581
1582 -- An expression typed at the prompt is treated very specially
1583 tcUserStmt (L loc (BodyStmt expr _ _ _))
1584 = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr)
1585 -- Don't try to typecheck if the renamer fails!
1586 ; ghciStep <- getGhciStepIO
1587 ; uniq <- newUnique
1588 ; interPrintName <- getInteractivePrintName
1589 ; let fresh_it = itName uniq loc
1590 matches = [mkMatch [] rn_expr emptyLocalBinds]
1591 -- [it = expr]
1592 the_bind = L loc $ (mkTopFunBind FromSource (L loc fresh_it) matches) { bind_fvs = fvs }
1593 -- Care here! In GHCi the expression might have
1594 -- free variables, and they in turn may have free type variables
1595 -- (if we are at a breakpoint, say). We must put those free vars
1596
1597 -- [let it = expr]
1598 let_stmt = L loc $ LetStmt $ HsValBinds $
1599 ValBindsOut [(NonRecursive,unitBag the_bind)] []
1600
1601 -- [it <- e]
1602 bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it))
1603 (nlHsApp ghciStep rn_expr)
1604 (HsVar bindIOName) noSyntaxExpr
1605
1606 -- [; print it]
1607 print_it = L loc $ BodyStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it))
1608 (HsVar thenIOName) noSyntaxExpr placeHolderType
1609
1610 -- The plans are:
1611 -- A. [it <- e; print it] but not if it::()
1612 -- B. [it <- e]
1613 -- C. [let it = e; print it]
1614 --
1615 -- Ensure that type errors don't get deferred when type checking the
1616 -- naked expression. Deferring type errors here is unhelpful because the
1617 -- expression gets evaluated right away anyway. It also would potentially
1618 -- emit two redundant type-error warnings, one from each plan.
1619 ; plan <- unsetGOptM Opt_DeferTypeErrors $ runPlans [
1620 -- Plan A
1621 do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
1622 ; it_ty <- zonkTcType (idType it_id)
1623 ; when (isUnitTy $ it_ty) failM
1624 ; return stuff },
1625
1626 -- Plan B; a naked bind statment
1627 tcGhciStmts [bind_stmt],
1628
1629 -- Plan C; check that the let-binding is typeable all by itself.
1630 -- If not, fail; if so, try to print it.
1631 -- The two-step process avoids getting two errors: one from
1632 -- the expression itself, and one from the 'print it' part
1633 -- This two-step story is very clunky, alas
1634 do { _ <- checkNoErrs (tcGhciStmts [let_stmt])
1635 --- checkNoErrs defeats the error recovery of let-bindings
1636 ; tcGhciStmts [let_stmt, print_it] } ]
1637
1638 ; fix_env <- getFixityEnv
1639 ; return (plan, fix_env) }
1640
1641 tcUserStmt rdr_stmt@(L loc _)
1642 = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $
1643 rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do
1644 fix_env <- getFixityEnv
1645 return (fix_env, emptyFVs)
1646 -- Don't try to typecheck if the renamer fails!
1647 ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs])
1648 ; rnDump (ppr rn_stmt) ;
1649
1650 ; ghciStep <- getGhciStepIO
1651 ; let gi_stmt
1652 | (L loc (BindStmt pat expr op1 op2)) <- rn_stmt
1653 = L loc $ BindStmt pat (nlHsApp ghciStep expr) op1 op2
1654 | otherwise = rn_stmt
1655
1656 ; opt_pr_flag <- goptM Opt_PrintBindResult
1657 ; let print_result_plan
1658 | opt_pr_flag -- The flag says "print result"
1659 , [v] <- collectLStmtBinders gi_stmt -- One binder
1660 = [mk_print_result_plan gi_stmt v]
1661 | otherwise = []
1662
1663 -- The plans are:
1664 -- [stmt; print v] if one binder and not v::()
1665 -- [stmt] otherwise
1666 ; plan <- runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]])
1667 ; return (plan, fix_env) }
1668 where
1669 mk_print_result_plan stmt v
1670 = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
1671 ; v_ty <- zonkTcType (idType v_id)
1672 ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM
1673 ; return stuff }
1674 where
1675 print_v = L loc $ BodyStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
1676 (HsVar thenIOName) noSyntaxExpr
1677 placeHolderType
1678
1679 -- | Typecheck the statements given and then return the results of the
1680 -- statement in the form 'IO [()]'.
1681 tcGhciStmts :: [GhciLStmt Name] -> TcM PlanResult
1682 tcGhciStmts stmts
1683 = do { ioTyCon <- tcLookupTyCon ioTyConName ;
1684 ret_id <- tcLookupId returnIOName ; -- return @ IO
1685 let {
1686 ret_ty = mkListTy unitTy ;
1687 io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
1688 tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts io_ret_ty ;
1689 names = collectLStmtsBinders stmts ;
1690 } ;
1691
1692 -- OK, we're ready to typecheck the stmts
1693 traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
1694 ((tc_stmts, ids), lie) <- captureConstraints $
1695 tc_io_stmts $ \ _ ->
1696 mapM tcLookupId names ;
1697 -- Look up the names right in the middle,
1698 -- where they will all be in scope
1699
1700 -- wanted constraints from static forms
1701 stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ;
1702
1703 -- Simplify the context
1704 traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
1705 const_binds <- checkNoErrs (simplifyInteractive (andWC stWC lie)) ;
1706 -- checkNoErrs ensures that the plan fails if context redn fails
1707
1708 traceTc "TcRnDriver.tcGhciStmts: done" empty ;
1709 let { -- mk_return builds the expression
1710 -- returnIO @ [()] [coerce () x, .., coerce () z]
1711 --
1712 -- Despite the inconvenience of building the type applications etc,
1713 -- this *has* to be done in type-annotated post-typecheck form
1714 -- because we are going to return a list of *polymorphic* values
1715 -- coerced to type (). If we built a *source* stmt
1716 -- return [coerce x, ..., coerce z]
1717 -- then the type checker would instantiate x..z, and we wouldn't
1718 -- get their *polymorphic* values. (And we'd get ambiguity errs
1719 -- if they were overloaded, since they aren't applied to anything.)
1720 ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty])
1721 (noLoc $ ExplicitList unitTy Nothing (map mk_item ids)) ;
1722 mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy])
1723 (nlHsVar id) ;
1724 stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]
1725 } ;
1726 return (ids, mkHsDictLet (EvBinds const_binds) $
1727 noLoc (HsDo GhciStmtCtxt stmts io_ret_ty))
1728 }
1729
1730 -- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a)
1731 getGhciStepIO :: TcM (LHsExpr Name)
1732 getGhciStepIO = do
1733 ghciTy <- getGHCiMonad
1734 fresh_a <- newUnique
1735 loc <- getSrcSpanM
1736 let a_tv = mkInternalName fresh_a (mkTyVarOccFS (fsLit "a")) loc
1737 ghciM = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)
1738 ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)
1739
1740 stepTy :: LHsType Name -- Renamed, so needs all binders in place
1741 stepTy = noLoc $ HsForAllTy Implicit Nothing
1742 (HsQTvs { hsq_tvs = [noLoc (UserTyVar a_tv)]
1743 , hsq_kvs = [] })
1744 (noLoc [])
1745 (nlHsFunTy ghciM ioM)
1746 step = noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy []
1747 return step
1748
1749 isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name)
1750 isGHCiMonad hsc_env ty
1751 = runTcInteractive hsc_env $ do
1752 rdrEnv <- getGlobalRdrEnv
1753 let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty)
1754 case occIO of
1755 Just [n] -> do
1756 let name = gre_name n
1757 ghciClass <- tcLookupClass ghciIoClassName
1758 userTyCon <- tcLookupTyCon name
1759 let userTy = mkTyConApp userTyCon []
1760 _ <- tcLookupInstance ghciClass [userTy]
1761 return name
1762
1763 Just _ -> failWithTc $ text "Ambigous type!"
1764 Nothing -> failWithTc $ text ("Can't find type:" ++ ty)
1765
1766 -- tcRnExpr just finds the type of an expression
1767
1768 tcRnExpr :: HscEnv
1769 -> LHsExpr RdrName
1770 -> IO (Messages, Maybe Type)
1771 -- Type checks the expression and returns its most general type
1772 tcRnExpr hsc_env rdr_expr
1773 = runTcInteractive hsc_env $
1774 do {
1775
1776 (rn_expr, _fvs) <- rnLExpr rdr_expr ;
1777 failIfErrsM ;
1778
1779 -- Now typecheck the expression, and generalise its type
1780 -- it might have a rank-2 type (e.g. :t runST)
1781 uniq <- newUnique ;
1782 let { fresh_it = itName uniq (getLoc rdr_expr) } ;
1783 ((_tc_expr, res_ty), tclvl, lie) <- pushLevelAndCaptureConstraints $
1784 tcInferRho rn_expr ;
1785 ((qtvs, dicts, _), lie_top) <- captureConstraints $
1786 {-# SCC "simplifyInfer" #-}
1787 simplifyInfer tclvl
1788 False {- No MR for now -}
1789 [] {- No sig vars -}
1790 [(fresh_it, res_ty)]
1791 lie ;
1792 -- Wanted constraints from static forms
1793 stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ;
1794
1795 -- Ignore the dictionary bindings
1796 _ <- simplifyInteractive (andWC stWC lie_top) ;
1797
1798 let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
1799 ty <- zonkTcType all_expr_ty ;
1800
1801 -- We normalise type families, so that the type of an expression is the
1802 -- same as of a bound expression (TcBinds.mkInferredPolyId). See Trac
1803 -- #10321 for further discussion.
1804 fam_envs <- tcGetFamInstEnvs ;
1805 -- normaliseType returns a coercion which we discard, so the Role is
1806 -- irrelevant
1807 return (snd (normaliseType fam_envs Nominal ty))
1808 }
1809
1810 --------------------------
1811 tcRnImportDecls :: HscEnv
1812 -> [LImportDecl RdrName]
1813 -> IO (Messages, Maybe GlobalRdrEnv)
1814 -- Find the new chunk of GlobalRdrEnv created by this list of import
1815 -- decls. In contract tcRnImports *extends* the TcGblEnv.
1816 tcRnImportDecls hsc_env import_decls
1817 = runTcInteractive hsc_env $
1818 do { gbl_env <- updGblEnv zap_rdr_env $
1819 tcRnImports hsc_env import_decls
1820 ; return (tcg_rdr_env gbl_env) }
1821 where
1822 zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv }
1823
1824 -- tcRnType just finds the kind of a type
1825
1826 tcRnType :: HscEnv
1827 -> Bool -- Normalise the returned type
1828 -> LHsType RdrName
1829 -> IO (Messages, Maybe (Type, Kind))
1830 tcRnType hsc_env normalise rdr_type
1831 = runTcInteractive hsc_env $
1832 setXOptM Opt_PolyKinds $ -- See Note [Kind-generalise in tcRnType]
1833 do { (rn_type, _fvs, wcs) <- rnLHsTypeWithWildCards GHCiCtx rdr_type
1834 ; failIfErrsM
1835
1836 -- Now kind-check the type
1837 -- It can have any rank or kind
1838 ; (ty, kind) <- tcWildcardBinders wcs $ \_ ->
1839 tcLHsType rn_type
1840
1841 -- Do kind generalisation; see Note [Kind-generalise in tcRnType]
1842 ; kvs <- zonkTcTypeAndFV kind
1843 ; kvs <- kindGeneralize kvs
1844 ; ty <- zonkTcTypeToType emptyZonkEnv ty
1845
1846 ; ty' <- if normalise
1847 then do { fam_envs <- tcGetFamInstEnvs
1848 ; return (snd (normaliseType fam_envs Nominal ty)) }
1849 -- normaliseType returns a coercion
1850 -- which we discard, so the Role is irrelevant
1851 else return ty ;
1852
1853 ; return (ty', mkForAllTys kvs (typeKind ty')) }
1854
1855 {- Note [Kind-generalise in tcRnType]
1856 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1857 We switch on PolyKinds when kind-checking a user type, so that we will
1858 kind-generalise the type, even when PolyKinds is not otherwise on.
1859 This gives the right default behaviour at the GHCi prompt, where if
1860 you say ":k T", and T has a polymorphic kind, you'd like to see that
1861 polymorphism. Of course. If T isn't kind-polymorphic you won't get
1862 anything unexpected, but the apparent *loss* of polymorphism, for
1863 types that you know are polymorphic, is quite surprising. See Trac
1864 #7688 for a discussion.
1865
1866 Note that the goal is to generalise the *kind of the type*, not
1867 the type itself! Example:
1868 ghci> data T m a = MkT (m a) -- T :: forall . (k -> *) -> k -> *
1869 ghci> :k T
1870 We instantiate T to get (T kappa). We do not want to kind-generalise
1871 that to forall k. T k! Rather we want to take its kind
1872 T kappa :: (kappa -> *) -> kappa -> *
1873 and now kind-generalise that kind, to forall k. (k->*) -> k -> *
1874 (It was Trac #10122 that made me realise how wrong the previous
1875 approach was.) -}
1876
1877
1878 {-
1879 ************************************************************************
1880 * *
1881 tcRnDeclsi
1882 * *
1883 ************************************************************************
1884
1885 tcRnDeclsi exists to allow class, data, and other declarations in GHCi.
1886 -}
1887
1888 tcRnDeclsi :: HscEnv
1889 -> [LHsDecl RdrName]
1890 -> IO (Messages, Maybe TcGblEnv)
1891 tcRnDeclsi hsc_env local_decls
1892 = runTcInteractive hsc_env $
1893 tcRnSrcDecls False Nothing local_decls
1894
1895 externaliseAndTidyId :: Module -> Id -> TcM Id
1896 externaliseAndTidyId this_mod id
1897 = do { name' <- externaliseName this_mod (idName id)
1898 ; return (globaliseAndTidyId (setIdName id name')) }
1899
1900 #endif /* GHCi */
1901
1902 {-
1903 ************************************************************************
1904 * *
1905 More GHCi stuff, to do with browsing and getting info
1906 * *
1907 ************************************************************************
1908 -}
1909
1910 #ifdef GHCI
1911 -- | ASSUMES that the module is either in the 'HomePackageTable' or is
1912 -- a package module with an interface on disk. If neither of these is
1913 -- true, then the result will be an error indicating the interface
1914 -- could not be found.
1915 getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface)
1916 getModuleInterface hsc_env mod
1917 = runTcInteractive hsc_env $
1918 loadModuleInterface (ptext (sLit "getModuleInterface")) mod
1919
1920 tcRnLookupRdrName :: HscEnv -> Located RdrName
1921 -> IO (Messages, Maybe [Name])
1922 -- ^ Find all the Names that this RdrName could mean, in GHCi
1923 tcRnLookupRdrName hsc_env (L loc rdr_name)
1924 = runTcInteractive hsc_env $
1925 setSrcSpan loc $
1926 do { -- If the identifier is a constructor (begins with an
1927 -- upper-case letter), then we need to consider both
1928 -- constructor and type class identifiers.
1929 let rdr_names = dataTcOccs rdr_name
1930 ; names_s <- mapM lookupInfoOccRn rdr_names
1931 ; let names = concat names_s
1932 ; when (null names) (addErrTc (ptext (sLit "Not in scope:") <+> quotes (ppr rdr_name)))
1933 ; return names }
1934 #endif
1935
1936 tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)
1937 tcRnLookupName hsc_env name
1938 = runTcInteractive hsc_env $
1939 tcRnLookupName' name
1940
1941 -- To look up a name we have to look in the local environment (tcl_lcl)
1942 -- as well as the global environment, which is what tcLookup does.
1943 -- But we also want a TyThing, so we have to convert:
1944
1945 tcRnLookupName' :: Name -> TcRn TyThing
1946 tcRnLookupName' name = do
1947 tcthing <- tcLookup name
1948 case tcthing of
1949 AGlobal thing -> return thing
1950 ATcId{tct_id=id} -> return (AnId id)
1951 _ -> panic "tcRnLookupName'"
1952
1953 tcRnGetInfo :: HscEnv
1954 -> Name
1955 -> IO (Messages, Maybe (TyThing, Fixity, [ClsInst], [FamInst]))
1956
1957 -- Used to implement :info in GHCi
1958 --
1959 -- Look up a RdrName and return all the TyThings it might be
1960 -- A capitalised RdrName is given to us in the DataName namespace,
1961 -- but we want to treat it as *both* a data constructor
1962 -- *and* as a type or class constructor;
1963 -- hence the call to dataTcOccs, and we return up to two results
1964 tcRnGetInfo hsc_env name
1965 = runTcInteractive hsc_env $
1966 do { loadUnqualIfaces hsc_env (hsc_IC hsc_env)
1967 -- Load the interface for all unqualified types and classes
1968 -- That way we will find all the instance declarations
1969 -- (Packages have not orphan modules, and we assume that
1970 -- in the home package all relevant modules are loaded.)
1971
1972 ; thing <- tcRnLookupName' name
1973 ; fixity <- lookupFixityRn name
1974 ; (cls_insts, fam_insts) <- lookupInsts thing
1975 ; return (thing, fixity, cls_insts, fam_insts) }
1976
1977 lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst])
1978 lookupInsts (ATyCon tc)
1979 = do { InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods } <- tcGetInstEnvs
1980 ; (pkg_fie, home_fie) <- tcGetFamInstEnvs
1981 -- Load all instances for all classes that are
1982 -- in the type environment (which are all the ones
1983 -- we've seen in any interface file so far)
1984
1985 -- Return only the instances relevant to the given thing, i.e.
1986 -- the instances whose head contains the thing's name.
1987 ; let cls_insts =
1988 [ ispec -- Search all
1989 | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
1990 , instIsVisible vis_mods ispec
1991 , tc_name `elemNameSet` orphNamesOfClsInst ispec ]
1992 ; let fam_insts =
1993 [ fispec
1994 | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie
1995 , tc_name `elemNameSet` orphNamesOfFamInst fispec ]
1996 ; return (cls_insts, fam_insts) }
1997 where
1998 tc_name = tyConName tc
1999
2000 lookupInsts _ = return ([],[])
2001
2002 loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM ()
2003 -- Load the interface for everything that is in scope unqualified
2004 -- This is so that we can accurately report the instances for
2005 -- something
2006 loadUnqualIfaces hsc_env ictxt
2007 = initIfaceTcRn $ do
2008 mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
2009 where
2010 this_pkg = thisPackage (hsc_dflags hsc_env)
2011
2012 unqual_mods = [ nameModule name
2013 | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt)
2014 , let name = gre_name gre
2015 , nameIsFromExternalPackage this_pkg name
2016 , isTcOcc (nameOccName name) -- Types and classes only
2017 , unQualOK gre ] -- In scope unqualified
2018 doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified")
2019
2020
2021 {-
2022 ************************************************************************
2023 * *
2024 Degugging output
2025 * *
2026 ************************************************************************
2027 -}
2028
2029 rnDump :: SDoc -> TcRn ()
2030 -- Dump, with a banner, if -ddump-rn
2031 rnDump doc = do { traceOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
2032
2033 tcDump :: TcGblEnv -> TcRn ()
2034 tcDump env
2035 = do { dflags <- getDynFlags ;
2036
2037 -- Dump short output if -ddump-types or -ddump-tc
2038 when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
2039 (printForUserTcRn short_dump) ;
2040
2041 -- Dump bindings if -ddump-tc
2042 traceOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
2043 }
2044 where
2045 short_dump = pprTcGblEnv env
2046 full_dump = pprLHsBinds (tcg_binds env)
2047 -- NB: foreign x-d's have undefined's in their types;
2048 -- hence can't show the tc_fords
2049
2050 -- It's unpleasant having both pprModGuts and pprModDetails here
2051 pprTcGblEnv :: TcGblEnv -> SDoc
2052 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
2053 tcg_insts = insts,
2054 tcg_fam_insts = fam_insts,
2055 tcg_rules = rules,
2056 tcg_vects = vects,
2057 tcg_imports = imports })
2058 = vcat [ ppr_types insts type_env
2059 , ppr_tycons fam_insts type_env
2060 , ppr_insts insts
2061 , ppr_fam_insts fam_insts
2062 , vcat (map ppr rules)
2063 , vcat (map ppr vects)
2064 , ptext (sLit "Dependent modules:") <+>
2065 ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))
2066 , ptext (sLit "Dependent packages:") <+>
2067 ppr (sortBy stableUnitIdCmp $ imp_dep_pkgs imports)]
2068 where -- The two uses of sortBy are just to reduce unnecessary
2069 -- wobbling in testsuite output
2070 cmp_mp (mod_name1, is_boot1) (mod_name2, is_boot2)
2071 = (mod_name1 `stableModuleNameCmp` mod_name2)
2072 `thenCmp`
2073 (is_boot1 `compare` is_boot2)
2074
2075 ppr_types :: [ClsInst] -> TypeEnv -> SDoc
2076 ppr_types insts type_env
2077 = text "TYPE SIGNATURES" $$ nest 2 (ppr_sigs ids)
2078 where
2079 dfun_ids = map instanceDFunId insts
2080 ids = [id | id <- typeEnvIds type_env, want_sig id]
2081 want_sig id | opt_PprStyle_Debug = True
2082 | otherwise = isLocalId id &&
2083 isExternalName (idName id) &&
2084 not (id `elem` dfun_ids)
2085 -- isLocalId ignores data constructors, records selectors etc.
2086 -- The isExternalName ignores local dictionary and method bindings
2087 -- that the type checker has invented. Top-level user-defined things
2088 -- have External names.
2089
2090 ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
2091 ppr_tycons fam_insts type_env
2092 = vcat [ text "TYPE CONSTRUCTORS"
2093 , nest 2 (ppr_tydecls tycons)
2094 , text "COERCION AXIOMS"
2095 , nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ]
2096 where
2097 fi_tycons = famInstsRepTyCons fam_insts
2098 tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon]
2099 want_tycon tycon | opt_PprStyle_Debug = True
2100 | otherwise = not (isImplicitTyCon tycon) &&
2101 isExternalName (tyConName tycon) &&
2102 not (tycon `elem` fi_tycons)
2103
2104 ppr_insts :: [ClsInst] -> SDoc
2105 ppr_insts [] = empty
2106 ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
2107
2108 ppr_fam_insts :: [FamInst] -> SDoc
2109 ppr_fam_insts [] = empty
2110 ppr_fam_insts fam_insts =
2111 text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts)
2112
2113 ppr_sigs :: [Var] -> SDoc
2114 ppr_sigs ids
2115 -- Print type signatures; sort by OccName
2116 = vcat (map ppr_sig (sortBy (comparing getOccName) ids))
2117 where
2118 ppr_sig id = hang (ppr id <+> dcolon) 2 (ppr (tidyTopType (idType id)))
2119
2120 ppr_tydecls :: [TyCon] -> SDoc
2121 ppr_tydecls tycons
2122 -- Print type constructor info; sort by OccName
2123 = vcat (map ppr_tycon (sortBy (comparing getOccName) tycons))
2124 where
2125 ppr_tycon tycon = vcat [ ppr (tyThingToIfaceDecl (ATyCon tycon)) ]
2126
2127 {-
2128 ********************************************************************************
2129
2130 Type Checker Plugins
2131
2132 ********************************************************************************
2133 -}
2134
2135 withTcPlugins :: HscEnv -> TcM a -> TcM a
2136 withTcPlugins hsc_env m =
2137 do plugins <- liftIO (loadTcPlugins hsc_env)
2138 case plugins of
2139 [] -> m -- Common fast case
2140 _ -> do (solvers,stops) <- unzip `fmap` mapM startPlugin plugins
2141 -- This ensures that tcPluginStop is called even if a type
2142 -- error occurs during compilation (Fix of #10078)
2143 eitherRes <- tryM $ do
2144 updGblEnv (\e -> e { tcg_tc_plugins = solvers }) m
2145 mapM_ (flip runTcPluginM Nothing) stops
2146 case eitherRes of
2147 Left _ -> failM
2148 Right res -> return res
2149 where
2150 startPlugin (TcPlugin start solve stop) =
2151 do s <- runTcPluginM start Nothing
2152 return (solve s, stop s)
2153
2154 loadTcPlugins :: HscEnv -> IO [TcPlugin]
2155 #ifndef GHCI
2156 loadTcPlugins _ = return []
2157 #else
2158 loadTcPlugins hsc_env =
2159 do named_plugins <- loadPlugins hsc_env
2160 return $ catMaybes $ map load_plugin named_plugins
2161 where
2162 load_plugin (_, plug, opts) = tcPlugin plug opts
2163 #endif