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