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