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