4c76cccf2aba15e180c0d76162d5549a7d5f4054
[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 Inst ( topInstantiate )
69 import MkIface
70 import TcSimplify
71 import TcTyClsDecls
72 import LoadIface
73 import TidyPgm ( mkBootModDetailsTc )
74 import RnNames
75 import RnEnv
76 import RnSource
77 import ErrUtils
78 import Id
79 import IdInfo( IdDetails( VanillaId ) )
80 import VarEnv
81 import Module
82 import UniqFM
83 import Name
84 import NameEnv
85 import NameSet
86 import Avail
87 import TyCon
88 import SrcLoc
89 import HscTypes
90 import ListSetOps
91 import Outputable
92 import ConLike
93 import DataCon
94 import Type
95 import Class
96 import BasicTypes hiding( SuccessFlag(..) )
97 import CoAxiom
98 import Annotations
99 import Data.List ( sortBy )
100 import Data.Ord
101 import FastString
102 import Maybes
103 import Util
104 import Bag
105
106 import Control.Monad
107
108 #include "HsVersions.h"
109
110 {-
111 ************************************************************************
112 * *
113 Typecheck and rename a module
114 * *
115 ************************************************************************
116 -}
117
118 -- | Top level entry point for typechecker and renamer
119 tcRnModule :: HscEnv
120 -> HscSource
121 -> Bool -- True <=> save renamed syntax
122 -> HsParsedModule
123 -> IO (Messages, Maybe TcGblEnv)
124
125 tcRnModule hsc_env hsc_src save_rn_syntax
126 parsedModule@HsParsedModule {hpm_module=L loc this_module}
127 | RealSrcSpan real_loc <- loc
128 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
129
130 ; initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $
131 withTcPlugins hsc_env $
132 tcRnModuleTcRnM hsc_env hsc_src parsedModule pair }
133
134 | otherwise
135 = return ((emptyBag, unitBag err_msg), Nothing)
136
137 where
138 err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $
139 text "Module does not have a RealSrcSpan:" <+> ppr this_mod
140
141 this_pkg = thisPackage (hsc_dflags hsc_env)
142
143 pair :: (Module, SrcSpan)
144 pair@(this_mod,_)
145 | Just (L mod_loc mod) <- hsmodName this_module
146 = (mkModule this_pkg mod, mod_loc)
147
148 | otherwise -- 'module M where' is omitted
149 = (mAIN, srcLocSpan (srcSpanStart loc))
150
151
152 -- To be called at the beginning of renaming hsig files.
153 -- If we're processing a signature, load up the RdrEnv
154 -- specified by sig-of so that
155 -- when we process top-level bindings, we pull in the right
156 -- original names. We also need to add in dependencies from
157 -- the implementation (orphans, family instances, packages),
158 -- similar to how rnImportDecl handles things.
159 -- ToDo: Handle SafeHaskell
160 tcRnSignature :: DynFlags -> HscSource -> TcRn TcGblEnv
161 tcRnSignature dflags hsc_src
162 = do { tcg_env <- getGblEnv ;
163 case tcg_sig_of tcg_env of {
164 Just sof
165 | hsc_src /= HsigFile -> do
166 { addErr (ptext (sLit "Illegal -sig-of specified for non hsig"))
167 ; return tcg_env
168 }
169 | otherwise -> do
170 { sig_iface <- initIfaceTcRn $ loadSysInterface (text "sig-of") sof
171 ; let { gr = mkGlobalRdrEnv
172 (gresFromAvails Nothing (mi_exports sig_iface))
173 ; avails = calculateAvails dflags
174 sig_iface False{- safe -} False{- boot -} }
175 ; return (tcg_env
176 { tcg_impl_rdr_env = Just gr
177 , tcg_imports = tcg_imports tcg_env `plusImportAvails` avails
178 })
179 } ;
180 Nothing
181 | HsigFile <- hsc_src
182 , HscNothing <- hscTarget dflags -> do
183 { return tcg_env
184 }
185 | HsigFile <- hsc_src -> do
186 { addErr (ptext (sLit "Missing -sig-of for hsig"))
187 ; failM }
188 | otherwise -> return tcg_env
189 }
190 }
191
192 checkHsigIface :: HscEnv -> TcGblEnv -> TcRn ()
193 checkHsigIface hsc_env tcg_env
194 = case tcg_impl_rdr_env tcg_env of
195 Just gr -> do { sig_details <- liftIO $ mkBootModDetailsTc hsc_env tcg_env
196 ; checkHsigIface' gr sig_details
197 }
198 Nothing -> return ()
199
200 checkHsigIface' :: GlobalRdrEnv -> ModDetails -> TcRn ()
201 checkHsigIface' gr
202 ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts,
203 md_types = sig_type_env, md_exports = sig_exports}
204 = do { traceTc "checkHsigIface" $ vcat
205 [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ]
206 ; mapM_ check_export sig_exports
207 ; unless (null sig_fam_insts) $
208 panic ("TcRnDriver.checkHsigIface: Cannot handle family " ++
209 "instances in hsig files yet...")
210 ; mapM_ check_inst sig_insts
211 ; failIfErrsM
212 }
213 where
214 check_export sig_avail
215 -- Skip instances, we'll check them later
216 | name `elem` dfun_names = return ()
217 | otherwise = do
218 { -- Lookup local environment only (don't want to accidentally pick
219 -- up the backing copy.) We consult tcg_type_env because we want
220 -- to pick up wired in names too (which get dropped by the iface
221 -- creation process); it's OK for a signature file to mention
222 -- a wired in name.
223 env <- getGblEnv
224 ; case lookupNameEnv (tcg_type_env env) name of
225 Nothing
226 -- All this means is no local definition is available: but we
227 -- could have created the export this way:
228 --
229 -- module ASig(f) where
230 -- import B(f)
231 --
232 -- In this case, we have to just lookup the identifier in
233 -- the backing implementation and make sure it matches.
234 | [GRE { gre_name = name' }]
235 <- lookupGlobalRdrEnv gr (nameOccName name)
236 , name == name' -> return ()
237 -- TODO: Possibly give a different error if the identifier
238 -- is exported, but it's a different original name
239 | otherwise -> addErrAt (nameSrcSpan name)
240 (missingBootThing False name "exported by")
241 Just sig_thing -> do {
242 -- We use tcLookupImported_maybe because we want to EXCLUDE
243 -- tcg_env.
244 ; r <- tcLookupImported_maybe name
245 ; case r of
246 Failed err -> addErr err
247 Succeeded real_thing -> checkBootDeclM False sig_thing real_thing
248 }}
249 where
250 name = availName sig_avail
251
252 dfun_names = map getName sig_insts
253
254 -- In general, for hsig files we can't assume that the implementing
255 -- file actually implemented the instances (they may be reexported
256 -- from elsewhere. Where should we look for the instances? We do
257 -- the same as we would otherwise: consult the EPS. This isn't
258 -- perfect (we might conclude the module exports an instance
259 -- when it doesn't, see #9422), but we will never refuse to compile
260 -- something
261 check_inst :: ClsInst -> TcM ()
262 check_inst sig_inst
263 = do eps <- getEps
264 when (not (memberInstEnv (eps_inst_env eps) sig_inst)) $
265 addErrTc (instMisMatch False sig_inst)
266
267 tcRnModuleTcRnM :: HscEnv
268 -> HscSource
269 -> HsParsedModule
270 -> (Module, SrcSpan)
271 -> TcRn TcGblEnv
272 -- Factored out separately from tcRnModule so that a Core plugin can
273 -- call the type checker directly
274 tcRnModuleTcRnM hsc_env hsc_src
275 (HsParsedModule {
276 hpm_module =
277 (L loc (HsModule maybe_mod export_ies
278 import_decls local_decls mod_deprec
279 maybe_doc_hdr)),
280 hpm_src_files = src_files
281 })
282 (this_mod, prel_imp_loc)
283 = setSrcSpan loc $
284 do { let { dflags = hsc_dflags hsc_env } ;
285
286 tcg_env <- tcRnSignature dflags hsc_src ;
287 setGblEnv tcg_env { tcg_mod_name=maybe_mod } $ do {
288
289 -- Deal with imports; first add implicit prelude
290 implicit_prelude <- xoptM Opt_ImplicitPrelude;
291 let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc
292 implicit_prelude import_decls } ;
293
294 whenWOptM Opt_WarnImplicitPrelude $
295 when (notNull prel_imports) $ addWarn (implicitPreludeWarn) ;
296
297 tcg_env <- {-# SCC "tcRnImports" #-}
298 tcRnImports hsc_env (prel_imports ++ import_decls) ;
299
300 -- If the whole module is warned about or deprecated
301 -- (via mod_deprec) record that in tcg_warns. If we do thereby add
302 -- a WarnAll, it will override any subseqent depracations added to tcg_warns
303 let { tcg_env1 = case mod_deprec of
304 Just (L _ txt) -> tcg_env { tcg_warns = WarnAll txt }
305 Nothing -> tcg_env
306 } ;
307
308 setGblEnv tcg_env1 $ do {
309
310 -- Load the hi-boot interface for this module, if any
311 -- We do this now so that the boot_names can be passed
312 -- to tcTyAndClassDecls, because the boot_names are
313 -- automatically considered to be loop breakers
314 --
315 -- Do this *after* tcRnImports, so that we know whether
316 -- a module that we import imports us; and hence whether to
317 -- look for a hi-boot file
318 boot_iface <- tcHiBootIface hsc_src this_mod ;
319
320 -- Rename and type check the declarations
321 traceRn (text "rn1a") ;
322 tcg_env <- if isHsBootOrSig hsc_src then
323 tcRnHsBootDecls hsc_src local_decls
324 else
325 {-# SCC "tcRnSrcDecls" #-}
326 tcRnSrcDecls boot_iface export_ies local_decls ;
327 setGblEnv tcg_env $ do {
328
329 -- Process the export list
330 traceRn (text "rn4a: before exports");
331 tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ;
332 traceRn (text "rn4b: after exports") ;
333
334 -- Check that main is exported (must be after rnExports)
335 checkMainExported tcg_env ;
336
337 -- Compare the hi-boot iface (if any) with the real thing
338 -- Must be done after processing the exports
339 tcg_env <- checkHiBootIface tcg_env boot_iface ;
340
341 -- Compare the hsig tcg_env with the real thing
342 checkHsigIface hsc_env tcg_env ;
343
344 -- Nub out type class instances now that we've checked them,
345 -- if we're compiling an hsig with sig-of.
346 -- See Note [Signature files and type class instances]
347 tcg_env <- (case tcg_sig_of tcg_env of
348 Just _ -> return tcg_env {
349 tcg_inst_env = emptyInstEnv,
350 tcg_fam_inst_env = emptyFamInstEnv,
351 tcg_insts = [],
352 tcg_fam_insts = []
353 }
354 Nothing -> return tcg_env) ;
355
356 -- The new type env is already available to stuff slurped from
357 -- interface files, via TcEnv.updateGlobalTypeEnv
358 -- It's important that this includes the stuff in checkHiBootIface,
359 -- because the latter might add new bindings for boot_dfuns,
360 -- which may be mentioned in imported unfoldings
361
362 -- Don't need to rename the Haddock documentation,
363 -- it's not parsed by GHC anymore.
364 tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ;
365
366 -- Report unused names
367 reportUnusedNames export_ies tcg_env ;
368
369 -- add extra source files to tcg_dependent_files
370 addDependentFiles src_files ;
371
372 -- Dump output and return
373 tcDump tcg_env ;
374 return tcg_env
375 }}}}
376
377 implicitPreludeWarn :: SDoc
378 implicitPreludeWarn
379 = ptext (sLit "Module `Prelude' implicitly imported")
380
381 {-
382 ************************************************************************
383 * *
384 Import declarations
385 * *
386 ************************************************************************
387 -}
388
389 tcRnImports :: HscEnv -> [LImportDecl RdrName] -> TcM TcGblEnv
390 tcRnImports hsc_env import_decls
391 = do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ;
392
393 ; this_mod <- getModule
394 ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
395 ; dep_mods = imp_dep_mods imports
396
397 -- We want instance declarations from all home-package
398 -- modules below this one, including boot modules, except
399 -- ourselves. The 'except ourselves' is so that we don't
400 -- get the instances from this module's hs-boot file. This
401 -- filtering also ensures that we don't see instances from
402 -- modules batch (@--make@) compiled before this one, but
403 -- which are not below this one.
404 ; want_instances :: ModuleName -> Bool
405 ; want_instances mod = mod `elemUFM` dep_mods
406 && mod /= moduleName this_mod
407 ; (home_insts, home_fam_insts) = hptInstances hsc_env
408 want_instances
409 } ;
410
411 -- Record boot-file info in the EPS, so that it's
412 -- visible to loadHiBootInterface in tcRnSrcDecls,
413 -- and any other incrementally-performed imports
414 ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
415
416 -- Update the gbl env
417 ; updGblEnv ( \ gbl ->
418 gbl {
419 tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env,
420 tcg_imports = tcg_imports gbl `plusImportAvails` imports,
421 tcg_rn_imports = rn_imports,
422 tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,
423 tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
424 home_fam_insts,
425 tcg_hpc = hpc_info
426 }) $ do {
427
428 ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports))
429 -- Fail if there are any errors so far
430 -- The error printing (if needed) takes advantage
431 -- of the tcg_env we have now set
432 -- ; traceIf (text "rdr_env: " <+> ppr rdr_env)
433 ; failIfErrsM
434
435 -- Load any orphan-module and family instance-module
436 -- interfaces, so that their rules and instance decls will be
437 -- found. But filter out a self hs-boot: these instances
438 -- will be checked when we define them locally.
439 ; loadModuleInterfaces (ptext (sLit "Loading orphan modules"))
440 (filter (/= this_mod) (imp_orphs imports))
441
442 -- Check type-family consistency
443 ; traceRn (text "rn1: checking family instance consistency")
444 ; let { dir_imp_mods = moduleEnvKeys
445 . imp_mods
446 $ imports }
447 ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ;
448
449 ; getGblEnv } }
450
451 {-
452 ************************************************************************
453 * *
454 Type-checking the top level of a module
455 * *
456 ************************************************************************
457 -}
458
459 tcRnSrcDecls :: ModDetails
460 -> Maybe (Located [LIE RdrName]) -- Exports
461 -> [LHsDecl RdrName] -- Declarations
462 -> TcM TcGblEnv
463 -- Returns the variables free in the decls
464 -- Reason: solely to report unused imports and bindings
465 tcRnSrcDecls boot_iface exports decls
466 = do { -- Do all the declarations
467 ((tcg_env, tcl_env), lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ;
468 ; traceTc "Tc8" empty ;
469 ; setEnvs (tcg_env, tcl_env) $
470 do {
471 -- wanted constraints from static forms
472 stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ;
473
474 -- Finish simplifying class constraints
475 --
476 -- simplifyTop deals with constant or ambiguous InstIds.
477 -- How could there be ambiguous ones? They can only arise if a
478 -- top-level decl falls under the monomorphism restriction
479 -- and no subsequent decl instantiates its type.
480 --
481 -- We do this after checkMain, so that we use the type info
482 -- that checkMain adds
483 --
484 -- We do it with both global and local env in scope:
485 -- * the global env exposes the instances to simplifyTop
486 -- * the local env exposes the local Ids to simplifyTop,
487 -- so that we get better error messages (monomorphism restriction)
488 new_ev_binds <- {-# SCC "simplifyTop" #-}
489 simplifyTop (andWC stWC lie) ;
490 traceTc "Tc9" empty ;
491
492 failIfErrsM ; -- Don't zonk if there have been errors
493 -- It's a waste of time; and we may get debug warnings
494 -- about strangely-typed TyCons!
495
496 -- Zonk the final code. This must be done last.
497 -- Even simplifyTop may do some unification.
498 -- This pass also warns about missing type signatures
499 let { TcGblEnv { tcg_type_env = type_env,
500 tcg_binds = binds,
501 tcg_sigs = sig_ns,
502 tcg_ev_binds = cur_ev_binds,
503 tcg_imp_specs = imp_specs,
504 tcg_rules = rules,
505 tcg_vects = vects,
506 tcg_fords = fords } = tcg_env
507 ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
508
509 (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
510 <- {-# SCC "zonkTopDecls" #-}
511 zonkTopDecls all_ev_binds binds exports sig_ns rules vects
512 imp_specs fords ;
513
514 let { final_type_env = extendTypeEnvWithIds type_env bind_ids
515 ; tcg_env' = tcg_env { tcg_binds = binds',
516 tcg_ev_binds = ev_binds',
517 tcg_imp_specs = imp_specs',
518 tcg_rules = rules',
519 tcg_vects = vects',
520 tcg_fords = fords' } } ;
521
522 setGlobalTypeEnv tcg_env' final_type_env
523
524 } }
525
526 tc_rn_src_decls :: ModDetails
527 -> [LHsDecl RdrName]
528 -> TcM (TcGblEnv, TcLclEnv)
529 -- Loops around dealing with each top level inter-splice group
530 -- in turn, until it's dealt with the entire module
531 tc_rn_src_decls boot_details ds
532 = {-# SCC "tc_rn_src_decls" #-}
533 do { (first_group, group_tail) <- findSplice ds
534 -- If ds is [] we get ([], Nothing)
535
536 -- The extra_deps are needed while renaming type and class declarations
537 -- See Note [Extra dependencies from .hs-boot files] in RnSource
538 ; let { tycons = typeEnvTyCons (md_types boot_details)
539 ; extra_deps | null tycons = Nothing
540 | otherwise = Just (mkFVs (map tyConName tycons)) }
541
542 -- Deal with decls up to, but not including, the first splice
543 ; (tcg_env, rn_decls) <- rnTopSrcDecls extra_deps first_group
544 -- rnTopSrcDecls fails if there are any errors
545
546 #ifdef GHCI
547 -- Get TH-generated top-level declarations and make sure they don't
548 -- contain any splices since we don't handle that at the moment
549 ; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv
550 ; th_ds <- readTcRef th_topdecls_var
551 ; writeTcRef th_topdecls_var []
552
553 ; (tcg_env, rn_decls) <-
554 if null th_ds
555 then return (tcg_env, rn_decls)
556 else do { (th_group, th_group_tail) <- findSplice th_ds
557 ; case th_group_tail of
558 { Nothing -> return () ;
559 ; Just (SpliceDecl (L loc _) _, _)
560 -> setSrcSpan loc $
561 addErr (ptext (sLit "Declaration splices are not permitted inside top-level declarations added with addTopDecls"))
562 } ;
563
564 -- Rename TH-generated top-level declarations
565 ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env $
566 rnTopSrcDecls extra_deps th_group
567
568 -- Dump generated top-level declarations
569 ; let msg = "top-level declarations added with addTopDecls"
570 ; traceSplice $ SpliceInfo { spliceDescription = msg
571 , spliceIsDecl = True
572 , spliceSource = Nothing
573 , spliceGenerated = ppr th_rn_decls }
574
575 ; return (tcg_env, appendGroups rn_decls th_rn_decls)
576 }
577 #endif /* GHCI */
578
579 -- Type check all declarations
580 ; (tcg_env, tcl_env) <- setGblEnv tcg_env $
581 tcTopSrcDecls boot_details rn_decls
582
583 -- If there is no splice, we're nearly done
584 ; setEnvs (tcg_env, tcl_env) $
585 case group_tail of
586 { Nothing -> do { tcg_env <- checkMain -- Check for `main'
587 #ifdef GHCI
588 -- Run all module finalizers
589 ; th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
590 ; modfinalizers <- readTcRef th_modfinalizers_var
591 ; writeTcRef th_modfinalizers_var []
592 ; mapM_ runQuasi modfinalizers
593 #endif /* GHCI */
594 ; return (tcg_env, tcl_env)
595 }
596
597 #ifndef GHCI
598 -- There shouldn't be a splice
599 ; Just (SpliceDecl {}, _) ->
600 failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
601 }
602 #else
603 -- If there's a splice, we must carry on
604 ; Just (SpliceDecl (L _ splice) _, rest_ds) ->
605 do { -- Rename the splice expression, and get its supporting decls
606 (spliced_decls, splice_fvs) <- checkNoErrs (rnTopSpliceDecls splice)
607
608 -- Glue them on the front of the remaining decls and loop
609 ; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
610 tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
611 }
612 }
613 #endif /* GHCI */
614 }
615
616 {-
617 ************************************************************************
618 * *
619 Compiling hs-boot source files, and
620 comparing the hi-boot interface with the real thing
621 * *
622 ************************************************************************
623 -}
624
625 tcRnHsBootDecls :: HscSource -> [LHsDecl RdrName] -> TcM TcGblEnv
626 tcRnHsBootDecls hsc_src decls
627 = do { (first_group, group_tail) <- findSplice decls
628
629 -- Rename the declarations
630 ; (tcg_env, HsGroup {
631 hs_tyclds = tycl_decls,
632 hs_instds = inst_decls,
633 hs_derivds = deriv_decls,
634 hs_fords = for_decls,
635 hs_defds = def_decls,
636 hs_ruleds = rule_decls,
637 hs_vects = vect_decls,
638 hs_annds = _,
639 hs_valds = val_binds }) <- rnTopSrcDecls Nothing first_group
640 -- The empty list is for extra dependencies coming from .hs-boot files
641 -- See Note [Extra dependencies from .hs-boot files] in RnSource
642 ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {
643
644
645 -- Check for illegal declarations
646 ; case group_tail of
647 Just (SpliceDecl d _, _) -> badBootDecl hsc_src "splice" d
648 Nothing -> return ()
649 ; mapM_ (badBootDecl hsc_src "foreign") for_decls
650 ; mapM_ (badBootDecl hsc_src "default") def_decls
651 ; mapM_ (badBootDecl hsc_src "rule") rule_decls
652 ; mapM_ (badBootDecl hsc_src "vect") vect_decls
653
654 -- Typecheck type/class/isntance decls
655 ; traceTc "Tc2 (boot)" empty
656 ; (tcg_env, inst_infos, _deriv_binds)
657 <- tcTyClsInstDecls emptyModDetails tycl_decls inst_decls deriv_decls
658 ; setGblEnv tcg_env $ do {
659
660 -- Typecheck value declarations
661 ; traceTc "Tc5" empty
662 ; val_ids <- tcHsBootSigs val_binds
663
664 -- Wrap up
665 -- No simplification or zonking to do
666 ; traceTc "Tc7a" empty
667 ; gbl_env <- getGblEnv
668
669 -- Make the final type-env
670 -- Include the dfun_ids so that their type sigs
671 -- are written into the interface file.
672 ; let { type_env0 = tcg_type_env gbl_env
673 ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
674 -- Don't add the dictionaries for hsig, we don't actually want
675 -- to /define/ the instance
676 ; type_env2 | HsigFile <- hsc_src = type_env1
677 | otherwise = extendTypeEnvWithIds type_env1 dfun_ids
678 ; dfun_ids = map iDFunId inst_infos
679 }
680
681 ; setGlobalTypeEnv gbl_env type_env2
682 }}
683 ; traceTc "boot" (ppr lie); return gbl_env }
684
685 badBootDecl :: HscSource -> String -> Located decl -> TcM ()
686 badBootDecl hsc_src what (L loc _)
687 = addErrAt loc (char 'A' <+> text what
688 <+> ptext (sLit "declaration is not (currently) allowed in a")
689 <+> (case hsc_src of
690 HsBootFile -> ptext (sLit "hs-boot")
691 HsigFile -> ptext (sLit "hsig")
692 _ -> panic "badBootDecl: should be an hsig or hs-boot file")
693 <+> ptext (sLit "file"))
694
695 {-
696 Once we've typechecked the body of the module, we want to compare what
697 we've found (gathered in a TypeEnv) with the hi-boot details (if any).
698 -}
699
700 checkHiBootIface :: TcGblEnv -> ModDetails -> TcM TcGblEnv
701 -- Compare the hi-boot file for this module (if there is one)
702 -- with the type environment we've just come up with
703 -- In the common case where there is no hi-boot file, the list
704 -- of boot_names is empty.
705
706 checkHiBootIface
707 tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds
708 , tcg_insts = local_insts
709 , tcg_type_env = local_type_env
710 , tcg_exports = local_exports })
711 boot_details
712 | HsBootFile <- hs_src -- Current module is already a hs-boot file!
713 = return tcg_env
714
715 | otherwise
716 = do { dfun_prs <- checkHiBootIface' local_insts local_type_env
717 local_exports boot_details
718 ; let boot_dfuns = map fst dfun_prs
719 dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
720 | (boot_dfun, dfun) <- dfun_prs ]
721 type_env' = extendTypeEnvWithIds local_type_env boot_dfuns
722 tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds }
723
724 ; setGlobalTypeEnv tcg_env' type_env' }
725 -- Update the global type env *including* the knot-tied one
726 -- so that if the source module reads in an interface unfolding
727 -- mentioning one of the dfuns from the boot module, then it
728 -- can "see" that boot dfun. See Trac #4003
729
730 checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo]
731 -> ModDetails -> TcM [(Id, Id)]
732 -- Variant which doesn't require a full TcGblEnv; you could get the
733 -- local components from another ModDetails.
734 --
735 -- We return a list of "impedance-matching" bindings for the dfuns
736 -- defined in the hs-boot file, such as
737 -- $fxEqT = $fEqT
738 -- We need these because the module and hi-boot file might differ in
739 -- the name it chose for the dfun.
740
741 checkHiBootIface'
742 local_insts local_type_env local_exports
743 (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
744 md_types = boot_type_env, md_exports = boot_exports })
745 = do { traceTc "checkHiBootIface" $ vcat
746 [ ppr boot_type_env, ppr boot_insts, ppr boot_exports]
747
748 -- Check the exports of the boot module, one by one
749 ; mapM_ check_export boot_exports
750
751 -- Check for no family instances
752 ; unless (null boot_fam_insts) $
753 panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
754 "instances in boot files yet...")
755 -- FIXME: Why? The actual comparison is not hard, but what would
756 -- be the equivalent to the dfun bindings returned for class
757 -- instances? We can't easily equate tycons...
758
759 -- Check instance declarations
760 -- and generate an impedance-matching binding
761 ; mb_dfun_prs <- mapM check_inst boot_insts
762
763 ; failIfErrsM
764
765 ; return (catMaybes mb_dfun_prs) }
766
767 where
768 check_export boot_avail -- boot_avail is exported by the boot iface
769 | name `elem` dfun_names = return ()
770 | isWiredInName name = return () -- No checking for wired-in names. In particular,
771 -- 'error' is handled by a rather gross hack
772 -- (see comments in GHC.Err.hs-boot)
773
774 -- Check that the actual module exports the same thing
775 | not (null missing_names)
776 = addErrAt (nameSrcSpan (head missing_names))
777 (missingBootThing True (head missing_names) "exported by")
778
779 -- If the boot module does not *define* the thing, we are done
780 -- (it simply re-exports it, and names match, so nothing further to do)
781 | isNothing mb_boot_thing = return ()
782
783 -- Check that the actual module also defines the thing, and
784 -- then compare the definitions
785 | Just real_thing <- lookupTypeEnv local_type_env name,
786 Just boot_thing <- mb_boot_thing
787 = checkBootDeclM True boot_thing real_thing
788
789 | otherwise
790 = addErrTc (missingBootThing True name "defined in")
791 where
792 name = availName boot_avail
793 mb_boot_thing = lookupTypeEnv boot_type_env name
794 missing_names = case lookupNameEnv local_export_env name of
795 Nothing -> [name]
796 Just avail -> availNames boot_avail `minusList` availNames avail
797
798 dfun_names = map getName boot_insts
799
800 local_export_env :: NameEnv AvailInfo
801 local_export_env = availsToNameEnv local_exports
802
803 check_inst :: ClsInst -> TcM (Maybe (Id, Id))
804 -- Returns a pair of the boot dfun in terms of the equivalent real dfun
805 check_inst boot_inst
806 = case [dfun | inst <- local_insts,
807 let dfun = instanceDFunId inst,
808 idType dfun `eqType` boot_dfun_ty ] of
809 [] -> do { traceTc "check_inst" $ vcat
810 [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts)
811 , text "boot_inst" <+> ppr boot_inst
812 , text "boot_dfun_ty" <+> ppr boot_dfun_ty
813 ]
814 ; addErrTc (instMisMatch True boot_inst); return Nothing }
815 (dfun:_) -> return (Just (local_boot_dfun, dfun))
816 where
817 local_boot_dfun = Id.mkExportedLocalId VanillaId boot_dfun_name (idType dfun)
818 -- Name from the /boot-file/ ClsInst, but type from the dfun
819 -- defined in /this module/. That ensures that the TyCon etc
820 -- inside the type are the ones defined in this module, not
821 -- the ones gotten from the hi-boot file, which may have
822 -- a lot less info (Trac #T8743, comment:10).
823 where
824 boot_dfun = instanceDFunId boot_inst
825 boot_dfun_ty = idType boot_dfun
826 boot_dfun_name = idName boot_dfun
827
828 -- This has to compare the TyThing from the .hi-boot file to the TyThing
829 -- in the current source file. We must be careful to allow alpha-renaming
830 -- where appropriate, and also the boot declaration is allowed to omit
831 -- constructors and class methods.
832 --
833 -- See rnfail055 for a good test of this stuff.
834
835 -- | Compares two things for equivalence between boot-file and normal code,
836 -- reporting an error if they don't match up.
837 checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig)
838 -> TyThing -> TyThing -> TcM ()
839 checkBootDeclM is_boot boot_thing real_thing
840 = whenIsJust (checkBootDecl boot_thing real_thing) $ \ err ->
841 addErrAt (nameSrcSpan (getName boot_thing))
842 (bootMisMatch is_boot err real_thing boot_thing)
843
844 -- | Compares the two things for equivalence between boot-file and normal
845 -- code. Returns @Nothing@ on success or @Just "some helpful info for user"@
846 -- failure. If the difference will be apparent to the user, @Just empty@ is
847 -- perfectly suitable.
848 checkBootDecl :: TyThing -> TyThing -> Maybe SDoc
849
850 checkBootDecl (AnId id1) (AnId id2)
851 = ASSERT(id1 == id2)
852 check (idType id1 `eqType` idType id2)
853 (text "The two types are different")
854
855 checkBootDecl (ATyCon tc1) (ATyCon tc2)
856 = checkBootTyCon tc1 tc2
857
858 checkBootDecl (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _))
859 = pprPanic "checkBootDecl" (ppr dc1)
860
861 checkBootDecl _ _ = Just empty -- probably shouldn't happen
862
863 -- | Combines two potential error messages
864 andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc
865 Nothing `andThenCheck` msg = msg
866 msg `andThenCheck` Nothing = msg
867 Just d1 `andThenCheck` Just d2 = Just (d1 $$ d2)
868 infixr 0 `andThenCheck`
869
870 -- | If the test in the first parameter is True, succeed with @Nothing@;
871 -- otherwise, return the provided check
872 checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc
873 checkUnless True _ = Nothing
874 checkUnless False k = k
875
876 -- | Run the check provided for every pair of elements in the lists.
877 -- The provided SDoc should name the element type, in the plural.
878 checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc
879 -> Maybe SDoc
880 checkListBy check_fun as bs whats = go [] as bs
881 where
882 herald = text "The" <+> whats <+> text "do not match"
883
884 go [] [] [] = Nothing
885 go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs))
886 go docs (x:xs) (y:ys) = case check_fun x y of
887 Just doc -> go (doc:docs) xs ys
888 Nothing -> go docs xs ys
889 go _ _ _ = Just (hang (herald <> colon)
890 2 (text "There are different numbers of" <+> whats))
891
892 -- | If the test in the first parameter is True, succeed with @Nothing@;
893 -- otherwise, fail with the given SDoc.
894 check :: Bool -> SDoc -> Maybe SDoc
895 check True _ = Nothing
896 check False doc = Just doc
897
898 -- | A more perspicuous name for @Nothing@, for @checkBootDecl@ and friends.
899 checkSuccess :: Maybe SDoc
900 checkSuccess = Nothing
901
902 ----------------
903 checkBootTyCon :: TyCon -> TyCon -> Maybe SDoc
904 checkBootTyCon tc1 tc2
905 | not (eqKind (tyConKind tc1) (tyConKind tc2))
906 = Just $ text "The types have different kinds" -- First off, check the kind
907
908 | Just c1 <- tyConClass_maybe tc1
909 , Just c2 <- tyConClass_maybe tc2
910 , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1)
911 = classExtraBigSig c1
912 (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2)
913 = classExtraBigSig c2
914 , Just env <- eqTyVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2
915 = let
916 eqSig (id1, def_meth1) (id2, def_meth2)
917 = check (name1 == name2)
918 (text "The names" <+> pname1 <+> text "and" <+> pname2 <+>
919 text "are different") `andThenCheck`
920 check (eqTypeX env op_ty1 op_ty2)
921 (text "The types of" <+> pname1 <+>
922 text "are different") `andThenCheck`
923 check (def_meth1 == def_meth2)
924 (text "The default methods associated with" <+> pname1 <+>
925 text "are different")
926 where
927 name1 = idName id1
928 name2 = idName id2
929 pname1 = quotes (ppr name1)
930 pname2 = quotes (ppr name2)
931 (_, rho_ty1) = splitForAllTys (idType id1)
932 op_ty1 = funResultTy rho_ty1
933 (_, rho_ty2) = splitForAllTys (idType id2)
934 op_ty2 = funResultTy rho_ty2
935
936 eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2)
937 = checkBootTyCon tc1 tc2 `andThenCheck`
938 check (eqATDef def_ats1 def_ats2)
939 (text "The associated type defaults differ")
940
941 -- Ignore the location of the defaults
942 eqATDef Nothing Nothing = True
943 eqATDef (Just ty1) (Just ty2) = eqTypeX env ty1 ty2
944 eqATDef _ _ = False
945
946 eqFD (as1,bs1) (as2,bs2) =
947 eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
948 eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
949 in
950 check (roles1 == roles2) roles_msg `andThenCheck`
951 -- Checks kind of class
952 check (eqListBy eqFD clas_fds1 clas_fds2)
953 (text "The functional dependencies do not match") `andThenCheck`
954 checkUnless (null sc_theta1 && null op_stuff1 && null ats1) $
955 -- Above tests for an "abstract" class
956 check (eqListBy (eqPredX env) sc_theta1 sc_theta2)
957 (text "The class constraints do not match") `andThenCheck`
958 checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck`
959 checkListBy eqAT ats1 ats2 (text "associated types")
960
961 | Just syn_rhs1 <- synTyConRhs_maybe tc1
962 , Just syn_rhs2 <- synTyConRhs_maybe tc2
963 , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
964 = ASSERT(tc1 == tc2)
965 check (roles1 == roles2) roles_msg `andThenCheck`
966 check (eqTypeX env syn_rhs1 syn_rhs2) empty -- nothing interesting to say
967
968 | Just fam_flav1 <- famTyConFlav_maybe tc1
969 , Just fam_flav2 <- famTyConFlav_maybe tc2
970 = ASSERT(tc1 == tc2)
971 let eqFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon = True
972 eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True
973 eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True
974 eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2)
975 = eqClosedFamilyAx ax1 ax2
976 eqFamFlav (BuiltInSynFamTyCon _) (BuiltInSynFamTyCon _) = tc1 == tc2
977 eqFamFlav _ _ = False
978 in
979 check (roles1 == roles2) roles_msg `andThenCheck`
980 check (eqFamFlav fam_flav1 fam_flav2) empty -- nothing interesting to say
981
982 | isAlgTyCon tc1 && isAlgTyCon tc2
983 , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
984 = ASSERT(tc1 == tc2)
985 check (roles1 == roles2) roles_msg `andThenCheck`
986 check (eqListBy (eqPredX env)
987 (tyConStupidTheta tc1) (tyConStupidTheta tc2))
988 (text "The datatype contexts do not match") `andThenCheck`
989 eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2)
990
991 | otherwise = Just empty -- two very different types -- should be obvious
992 where
993 roles1 = tyConRoles tc1
994 roles2 = tyConRoles tc2
995 roles_msg = text "The roles do not match." $$
996 (text "Roles on abstract types default to" <+>
997 quotes (text "representational") <+> text "in boot files.")
998
999 eqAlgRhs tc (AbstractTyCon dis1) rhs2
1000 | dis1 = check (isGenInjAlgRhs rhs2) --Check compatibility
1001 (text "The natures of the declarations for" <+>
1002 quotes (ppr tc) <+> text "are different")
1003 | otherwise = checkSuccess
1004 eqAlgRhs _ DataFamilyTyCon{} DataFamilyTyCon{} = checkSuccess
1005 eqAlgRhs _ tc1@DataTyCon{} tc2@DataTyCon{} =
1006 checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors")
1007 eqAlgRhs _ tc1@NewTyCon{} tc2@NewTyCon{} =
1008 eqCon (data_con tc1) (data_con tc2)
1009 eqAlgRhs _ _ _ = Just (text "Cannot match a" <+> quotes (text "data") <+>
1010 text "definition with a" <+> quotes (text "newtype") <+>
1011 text "definition")
1012
1013 eqCon c1 c2
1014 = check (name1 == name2)
1015 (text "The names" <+> pname1 <+> text "and" <+> pname2 <+>
1016 text "differ") `andThenCheck`
1017 check (dataConIsInfix c1 == dataConIsInfix c2)
1018 (text "The fixities of" <+> pname1 <+>
1019 text "differ") `andThenCheck`
1020 check (eqListBy eqHsBang
1021 (dataConSrcBangs c1) (dataConSrcBangs c2))
1022 (text "The strictness annotations for" <+> pname1 <+>
1023 text "differ") `andThenCheck`
1024 check (dataConFieldLabels c1 == dataConFieldLabels c2)
1025 (text "The record label lists for" <+> pname1 <+>
1026 text "differ") `andThenCheck`
1027 check (eqType (dataConUserType c1) (dataConUserType c2))
1028 (text "The types for" <+> pname1 <+> text "differ")
1029 where
1030 name1 = dataConName c1
1031 name2 = dataConName c2
1032 pname1 = quotes (ppr name1)
1033 pname2 = quotes (ppr name2)
1034
1035 eqClosedFamilyAx Nothing Nothing = True
1036 eqClosedFamilyAx Nothing (Just _) = False
1037 eqClosedFamilyAx (Just _) Nothing = False
1038 eqClosedFamilyAx (Just (CoAxiom { co_ax_branches = branches1 }))
1039 (Just (CoAxiom { co_ax_branches = branches2 }))
1040 = brListLength branches1 == brListLength branches2
1041 && (and $ brListZipWith eqClosedFamilyBranch branches1 branches2)
1042
1043 eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_lhs = lhs1, cab_rhs = rhs1 })
1044 (CoAxBranch { cab_tvs = tvs2, cab_lhs = lhs2, cab_rhs = rhs2 })
1045 | Just env <- eqTyVarBndrs emptyRnEnv2 tvs1 tvs2
1046 = eqListBy (eqTypeX env) lhs1 lhs2 &&
1047 eqTypeX env rhs1 rhs2
1048
1049 | otherwise = False
1050
1051 emptyRnEnv2 :: RnEnv2
1052 emptyRnEnv2 = mkRnEnv2 emptyInScopeSet
1053
1054 ----------------
1055 missingBootThing :: Bool -> Name -> String -> SDoc
1056 missingBootThing is_boot name what
1057 = quotes (ppr name) <+> ptext (sLit "is exported by the")
1058 <+> (if is_boot then ptext (sLit "hs-boot") else ptext (sLit "hsig"))
1059 <+> ptext (sLit "file, but not")
1060 <+> text what <+> ptext (sLit "the module")
1061
1062 bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc
1063 bootMisMatch is_boot extra_info real_thing boot_thing
1064 = vcat [ppr real_thing <+>
1065 ptext (sLit "has conflicting definitions in the module"),
1066 ptext (sLit "and its") <+>
1067 (if is_boot then ptext (sLit "hs-boot file")
1068 else ptext (sLit "hsig file")),
1069 ptext (sLit "Main module:") <+> PprTyThing.pprTyThing real_thing,
1070 (if is_boot
1071 then ptext (sLit "Boot file: ")
1072 else ptext (sLit "Hsig file: "))
1073 <+> PprTyThing.pprTyThing boot_thing,
1074 extra_info]
1075
1076 instMisMatch :: Bool -> ClsInst -> SDoc
1077 instMisMatch is_boot inst
1078 = hang (ppr inst)
1079 2 (ptext (sLit "is defined in the") <+>
1080 (if is_boot then ptext (sLit "hs-boot") else ptext (sLit "hsig"))
1081 <+> ptext (sLit "file, but not in the module itself"))
1082
1083 {-
1084 ************************************************************************
1085 * *
1086 Type-checking the top level of a module (continued)
1087 * *
1088 ************************************************************************
1089 -}
1090
1091 rnTopSrcDecls :: Maybe FreeVars -> HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
1092 -- Fails if there are any errors
1093 rnTopSrcDecls extra_deps group
1094 = do { -- Rename the source decls
1095 traceTc "rn12" empty ;
1096 (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls extra_deps group ;
1097 traceTc "rn13" empty ;
1098
1099 -- save the renamed syntax, if we want it
1100 let { tcg_env'
1101 | Just grp <- tcg_rn_decls tcg_env
1102 = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
1103 | otherwise
1104 = tcg_env };
1105
1106 -- Dump trace of renaming part
1107 rnDump (ppr rn_decls) ;
1108
1109 return (tcg_env', rn_decls)
1110 }
1111
1112 tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
1113 tcTopSrcDecls boot_details
1114 (HsGroup { hs_tyclds = tycl_decls,
1115 hs_instds = inst_decls,
1116 hs_derivds = deriv_decls,
1117 hs_fords = foreign_decls,
1118 hs_defds = default_decls,
1119 hs_annds = annotation_decls,
1120 hs_ruleds = rule_decls,
1121 hs_vects = vect_decls,
1122 hs_valds = val_binds })
1123 = do { -- Type-check the type and class decls, and all imported decls
1124 -- The latter come in via tycl_decls
1125 traceTc "Tc2 (src)" empty ;
1126
1127 -- Source-language instances, including derivings,
1128 -- and import the supporting declarations
1129 traceTc "Tc3" empty ;
1130 (tcg_env, inst_infos, deriv_binds)
1131 <- tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls ;
1132 setGblEnv tcg_env $ do {
1133
1134
1135 -- Generate Applicative/Monad proposal (AMP) warnings
1136 traceTc "Tc3b" empty ;
1137
1138 -- Foreign import declarations next.
1139 traceTc "Tc4" empty ;
1140 (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ;
1141 tcExtendGlobalValEnv fi_ids $ do {
1142
1143 -- Default declarations
1144 traceTc "Tc4a" empty ;
1145 default_tys <- tcDefaults default_decls ;
1146 updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
1147
1148 -- Now GHC-generated derived bindings, generics, and selectors
1149 -- Do not generate warnings from compiler-generated code;
1150 -- hence the use of discardWarnings
1151 tc_envs <- discardWarnings (tcTopBinds deriv_binds) ;
1152 setEnvs tc_envs $ do {
1153
1154 -- Value declarations next
1155 traceTc "Tc5" empty ;
1156 tc_envs@(tcg_env, tcl_env) <- tcTopBinds val_binds;
1157 setEnvs tc_envs $ do { -- Environment doesn't change now
1158
1159 -- Second pass over class and instance declarations,
1160 -- now using the kind-checked decls
1161 traceTc "Tc6" empty ;
1162 inst_binds <- tcInstDecls2 (tyClGroupConcat tycl_decls) inst_infos ;
1163
1164 -- Foreign exports
1165 traceTc "Tc7" empty ;
1166 (foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ;
1167
1168 -- Annotations
1169 annotations <- tcAnnotations annotation_decls ;
1170
1171 -- Rules
1172 rules <- tcRules rule_decls ;
1173
1174 -- Vectorisation declarations
1175 vects <- tcVectDecls vect_decls ;
1176
1177 -- Wrap up
1178 traceTc "Tc7a" empty ;
1179 let { all_binds = inst_binds `unionBags`
1180 foe_binds
1181
1182 ; fo_gres = fi_gres `unionBags` foe_gres
1183 ; fo_fvs = foldrBag (\gre fvs -> fvs `addOneFV` gre_name gre)
1184 emptyFVs fo_gres
1185 ; fo_rdr_names :: [RdrName]
1186 ; fo_rdr_names = foldrBag gre_to_rdr_name [] fo_gres
1187
1188 ; sig_names = mkNameSet (collectHsValBinders val_binds)
1189 `minusNameSet` getTypeSigNames val_binds
1190
1191 -- Extend the GblEnv with the (as yet un-zonked)
1192 -- bindings, rules, foreign decls
1193 ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds
1194 , tcg_sigs = tcg_sigs tcg_env `unionNameSet` sig_names
1195 , tcg_rules = tcg_rules tcg_env
1196 ++ flattenRuleDecls rules
1197 , tcg_vects = tcg_vects tcg_env ++ vects
1198 , tcg_anns = tcg_anns tcg_env ++ annotations
1199 , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations
1200 , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls
1201 , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ;
1202 -- tcg_dus: see Note [Newtype constructor usage in foreign declarations]
1203
1204 addUsedRdrNames fo_rdr_names ;
1205 return (tcg_env', tcl_env)
1206 }}}}}}
1207 where
1208 gre_to_rdr_name :: GlobalRdrElt -> [RdrName] -> [RdrName]
1209 -- For *imported* newtype data constructors, we want to
1210 -- make sure that at least one of the imports for them is used
1211 -- See Note [Newtype constructor usage in foreign declarations]
1212 gre_to_rdr_name gre rdrs
1213 | isLocalGRE gre = rdrs
1214 | otherwise = greUsedRdrName gre : rdrs
1215
1216 ---------------------------
1217 tcTyClsInstDecls :: ModDetails
1218 -> [TyClGroup Name]
1219 -> [LInstDecl Name]
1220 -> [LDerivDecl Name]
1221 -> TcM (TcGblEnv, -- The full inst env
1222 [InstInfo Name], -- Source-code instance decls to process;
1223 -- contains all dfuns for this module
1224 HsValBinds Name) -- Supporting bindings for derived instances
1225
1226 tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls
1227 = tcExtendKindEnv2 [ (con, APromotionErr FamDataConPE)
1228 | lid <- inst_decls, con <- get_cons lid ] $
1229 -- Note [AFamDataCon: not promoting data family constructors]
1230 do { tcg_env <- tcTyAndClassDecls boot_details tycl_decls ;
1231 ; setGblEnv tcg_env $
1232 tcInstDecls1 (tyClGroupConcat tycl_decls) inst_decls deriv_decls }
1233 where
1234 -- get_cons extracts the *constructor* bindings of the declaration
1235 get_cons :: LInstDecl Name -> [Name]
1236 get_cons (L _ (TyFamInstD {})) = []
1237 get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid
1238 get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))
1239 = concatMap (get_fi_cons . unLoc) fids
1240
1241 get_fi_cons :: DataFamInstDecl Name -> [Name]
1242 get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } })
1243 = map unLoc $ concatMap (con_names . unLoc) cons
1244
1245 {-
1246 Note [AFamDataCon: not promoting data family constructors]
1247 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1248 Consider
1249 data family T a
1250 data instance T Int = MkT
1251 data Proxy (a :: k)
1252 data S = MkS (Proxy 'MkT)
1253
1254 Is it ok to use the promoted data family instance constructor 'MkT' in
1255 the data declaration for S? No, we don't allow this. It *might* make
1256 sense, but at least it would mean that we'd have to interleave
1257 typechecking instances and data types, whereas at present we do data
1258 types *then* instances.
1259
1260 So to check for this we put in the TcLclEnv a binding for all the family
1261 constructors, bound to AFamDataCon, so that if we trip over 'MkT' when
1262 type checking 'S' we'll produce a decent error message.
1263
1264
1265 ************************************************************************
1266 * *
1267 Checking for 'main'
1268 * *
1269 ************************************************************************
1270 -}
1271
1272 checkMain :: TcM TcGblEnv
1273 -- If we are in module Main, check that 'main' is defined.
1274 checkMain
1275 = do { tcg_env <- getGblEnv ;
1276 dflags <- getDynFlags ;
1277 check_main dflags tcg_env
1278 }
1279
1280 check_main :: DynFlags -> TcGblEnv -> TcM TcGblEnv
1281 check_main dflags tcg_env
1282 | mod /= main_mod
1283 = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >>
1284 return tcg_env
1285
1286 | otherwise
1287 = do { mb_main <- lookupGlobalOccRn_maybe main_fn
1288 -- Check that 'main' is in scope
1289 -- It might be imported from another module!
1290 ; case mb_main of {
1291 Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn)
1292 ; complain_no_main
1293 ; return tcg_env } ;
1294 Just main_name -> do
1295
1296 { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn)
1297 ; let loc = srcLocSpan (getSrcLoc main_name)
1298 ; ioTyCon <- tcLookupTyCon ioTyConName
1299 ; res_ty <- newFlexiTyVarTy liftedTypeKind
1300 ; main_expr
1301 <- addErrCtxt mainCtxt $
1302 tcPolyExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty])
1303
1304 -- See Note [Root-main Id]
1305 -- Construct the binding
1306 -- :Main.main :: IO res_ty = runMainIO res_ty main
1307 ; run_main_id <- tcLookupId runMainIOName
1308 ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN
1309 (mkVarOccFS (fsLit "main"))
1310 (getSrcSpan main_name)
1311 ; root_main_id = Id.mkExportedLocalId VanillaId root_main_name
1312 (mkTyConApp ioTyCon [res_ty])
1313 ; co = mkWpTyApps [res_ty]
1314 ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
1315 ; main_bind = mkVarBind root_main_id rhs }
1316
1317 ; return (tcg_env { tcg_main = Just main_name,
1318 tcg_binds = tcg_binds tcg_env
1319 `snocBag` main_bind,
1320 tcg_dus = tcg_dus tcg_env
1321 `plusDU` usesOnly (unitFV main_name)
1322 -- Record the use of 'main', so that we don't
1323 -- complain about it being defined but not used
1324 })
1325 }}}
1326 where
1327 mod = tcg_mod tcg_env
1328 main_mod = mainModIs dflags
1329 main_fn = getMainFun dflags
1330 interactive = ghcLink dflags == LinkInMemory
1331 implicit_mod = isNothing (tcg_mod_name tcg_env)
1332
1333 complain_no_main = checkTc (interactive && implicit_mod) noMainMsg
1334 -- In interactive mode, without an explicit module header, don't
1335 -- worry about the absence of 'main'.
1336 -- In other modes, fail altogether, so that we don't go on
1337 -- and complain a second time when processing the export list.
1338
1339 mainCtxt = ptext (sLit "When checking the type of the") <+> pp_main_fn
1340 noMainMsg = ptext (sLit "The") <+> pp_main_fn
1341 <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod)
1342 pp_main_fn = ppMainFn main_fn
1343
1344 -- | Get the unqualified name of the function to use as the \"main\" for the main module.
1345 -- Either returns the default name or the one configured on the command line with -main-is
1346 getMainFun :: DynFlags -> RdrName
1347 getMainFun dflags = case mainFunIs dflags of
1348 Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn))
1349 Nothing -> main_RDR_Unqual
1350
1351 -- If we are in module Main, check that 'main' is exported.
1352 checkMainExported :: TcGblEnv -> TcM ()
1353 checkMainExported tcg_env
1354 = case tcg_main tcg_env of
1355 Nothing -> return () -- not the main module
1356 Just main_name ->
1357 do { dflags <- getDynFlags
1358 ; let main_mod = mainModIs dflags
1359 ; checkTc (main_name `elem` concatMap availNames (tcg_exports tcg_env)) $
1360 ptext (sLit "The") <+> ppMainFn (nameRdrName main_name) <+>
1361 ptext (sLit "is not exported by module") <+> quotes (ppr main_mod) }
1362
1363 ppMainFn :: RdrName -> SDoc
1364 ppMainFn main_fn
1365 | rdrNameOcc main_fn == mainOcc
1366 = ptext (sLit "IO action") <+> quotes (ppr main_fn)
1367 | otherwise
1368 = ptext (sLit "main IO action") <+> quotes (ppr main_fn)
1369
1370 mainOcc :: OccName
1371 mainOcc = mkVarOccFS (fsLit "main")
1372
1373 {-
1374 Note [Root-main Id]
1375 ~~~~~~~~~~~~~~~~~~~
1376 The function that the RTS invokes is always :Main.main, which we call
1377 root_main_id. (Because GHC allows the user to have a module not
1378 called Main as the main module, we can't rely on the main function
1379 being called "Main.main". That's why root_main_id has a fixed module
1380 ":Main".)
1381
1382 This is unusual: it's a LocalId whose Name has a Module from another
1383 module. Tiresomely, we must filter it out again in MkIface, les we
1384 get two defns for 'main' in the interface file!
1385
1386
1387 *********************************************************
1388 * *
1389 GHCi stuff
1390 * *
1391 *********************************************************
1392 -}
1393
1394 runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a)
1395 -- Initialise the tcg_inst_env with instances from all home modules.
1396 -- This mimics the more selective call to hptInstances in tcRnImports
1397 runTcInteractive hsc_env thing_inside
1398 = initTcInteractive hsc_env $ withTcPlugins hsc_env $
1399 do { traceTc "setInteractiveContext" $
1400 vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))
1401 , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts)
1402 , text "ic_rn_gbl_env (LocalDef)" <+>
1403 vcat (map ppr [ local_gres | gres <- occEnvElts (ic_rn_gbl_env icxt)
1404 , let local_gres = filter isLocalGRE gres
1405 , not (null local_gres) ]) ]
1406 ; let getOrphans m = fmap (\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 tcInferSigma rn_expr ;
1800 (_wrap, res_tau) <- topInstantiate GeneraliseOrigin res_ty ;
1801 ((qtvs, dicts, _, _), lie_top) <- captureConstraints $
1802 {-# SCC "simplifyInfer" #-}
1803 simplifyInfer tclvl
1804 False {- No MR for now -}
1805 [(fresh_it, res_tau)]
1806 lie ;
1807 -- Wanted constraints from static forms
1808 stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ;
1809
1810 -- Ignore the dictionary bindings
1811 _ <- simplifyInteractive (andWC stWC lie_top) ;
1812
1813 let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_tau) } ;
1814 ty <- zonkTcType all_expr_ty ;
1815
1816 -- We normalise type families, so that the type of an expression is the
1817 -- same as of a bound expression (TcBinds.mkInferredPolyId). See Trac
1818 -- #10321 for further discussion.
1819 fam_envs <- tcGetFamInstEnvs ;
1820 -- normaliseType returns a coercion which we discard, so the Role is
1821 -- irrelevant
1822 return (snd (normaliseType fam_envs Nominal ty))
1823 }
1824
1825 --------------------------
1826 tcRnImportDecls :: HscEnv
1827 -> [LImportDecl RdrName]
1828 -> IO (Messages, Maybe GlobalRdrEnv)
1829 -- Find the new chunk of GlobalRdrEnv created by this list of import
1830 -- decls. In contract tcRnImports *extends* the TcGblEnv.
1831 tcRnImportDecls hsc_env import_decls
1832 = runTcInteractive hsc_env $
1833 do { gbl_env <- updGblEnv zap_rdr_env $
1834 tcRnImports hsc_env import_decls
1835 ; return (tcg_rdr_env gbl_env) }
1836 where
1837 zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv }
1838
1839 -- tcRnType just finds the kind of a type
1840
1841 tcRnType :: HscEnv
1842 -> Bool -- Normalise the returned type
1843 -> LHsType RdrName
1844 -> IO (Messages, Maybe (Type, Kind))
1845 tcRnType hsc_env normalise rdr_type
1846 = runTcInteractive hsc_env $
1847 setXOptM Opt_PolyKinds $ -- See Note [Kind-generalise in tcRnType]
1848 do { (rn_type, _fvs, wcs) <- rnLHsTypeWithWildCards GHCiCtx rdr_type
1849 ; failIfErrsM
1850
1851 -- Now kind-check the type
1852 -- It can have any rank or kind
1853 ; nwc_tvs <- mapM newWildcardVarMetaKind wcs
1854 ; (ty, kind) <- tcExtendTyVarEnv nwc_tvs $
1855 tcLHsType rn_type
1856
1857 -- Do kind generalisation; see Note [Kind-generalise in tcRnType]
1858 ; kvs <- zonkTcTypeAndFV kind
1859 ; kvs <- kindGeneralize kvs
1860 ; ty <- zonkTcTypeToType emptyZonkEnv ty
1861
1862 ; ty' <- if normalise
1863 then do { fam_envs <- tcGetFamInstEnvs
1864 ; return (snd (normaliseType fam_envs Nominal ty)) }
1865 -- normaliseType returns a coercion
1866 -- which we discard, so the Role is irrelevant
1867 else return ty ;
1868
1869 ; return (ty', mkForAllTys kvs (typeKind ty')) }
1870
1871 {- Note [Kind-generalise in tcRnType]
1872 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1873 We switch on PolyKinds when kind-checking a user type, so that we will
1874 kind-generalise the type, even when PolyKinds is not otherwise on.
1875 This gives the right default behaviour at the GHCi prompt, where if
1876 you say ":k T", and T has a polymorphic kind, you'd like to see that
1877 polymorphism. Of course. If T isn't kind-polymorphic you won't get
1878 anything unexpected, but the apparent *loss* of polymorphism, for
1879 types that you know are polymorphic, is quite surprising. See Trac
1880 #7688 for a discussion.
1881
1882 Note that the goal is to generalise the *kind of the type*, not
1883 the type itself! Example:
1884 ghci> data T m a = MkT (m a) -- T :: forall . (k -> *) -> k -> *
1885 ghci> :k T
1886 We instantiate T to get (T kappa). We do not want to kind-generalise
1887 that to forall k. T k! Rather we want to take its kind
1888 T kappa :: (kappa -> *) -> kappa -> *
1889 and now kind-generalise that kind, to forall k. (k->*) -> k -> *
1890 (It was Trac #10122 that made me realise how wrong the previous
1891 approach was.) -}
1892
1893
1894 {-
1895 ************************************************************************
1896 * *
1897 tcRnDeclsi
1898 * *
1899 ************************************************************************
1900
1901 tcRnDeclsi exists to allow class, data, and other declarations in GHCi.
1902 -}
1903
1904 tcRnDeclsi :: HscEnv
1905 -> [LHsDecl RdrName]
1906 -> IO (Messages, Maybe TcGblEnv)
1907
1908 tcRnDeclsi hsc_env local_decls =
1909 runTcInteractive hsc_env $ do
1910
1911 ((tcg_env, tclcl_env), lie) <-
1912 captureConstraints $ tc_rn_src_decls emptyModDetails local_decls
1913 setEnvs (tcg_env, tclcl_env) $ do
1914
1915 -- wanted constraints from static forms
1916 stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef
1917
1918 new_ev_binds <- simplifyTop (andWC stWC lie)
1919
1920 failIfErrsM
1921 let TcGblEnv { tcg_type_env = type_env,
1922 tcg_binds = binds,
1923 tcg_sigs = sig_ns,
1924 tcg_ev_binds = cur_ev_binds,
1925 tcg_imp_specs = imp_specs,
1926 tcg_rules = rules,
1927 tcg_vects = vects,
1928 tcg_fords = fords } = tcg_env
1929 all_ev_binds = cur_ev_binds `unionBags` new_ev_binds
1930
1931 (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
1932 <- zonkTopDecls all_ev_binds binds Nothing sig_ns rules vects
1933 imp_specs fords
1934
1935 let final_type_env = extendTypeEnvWithIds type_env bind_ids
1936 tcg_env' = tcg_env { tcg_binds = binds',
1937 tcg_ev_binds = ev_binds',
1938 tcg_imp_specs = imp_specs',
1939 tcg_rules = rules',
1940 tcg_vects = vects',
1941 tcg_fords = fords' }
1942
1943 setGlobalTypeEnv tcg_env' final_type_env
1944
1945
1946 externaliseAndTidyId :: Module -> Id -> TcM Id
1947 externaliseAndTidyId this_mod id
1948 = do { name' <- externaliseName this_mod (idName id)
1949 ; return (globaliseAndTidyId (setIdName id name')) }
1950
1951 #endif /* GHCi */
1952
1953 {-
1954 ************************************************************************
1955 * *
1956 More GHCi stuff, to do with browsing and getting info
1957 * *
1958 ************************************************************************
1959 -}
1960
1961 #ifdef GHCI
1962 -- | ASSUMES that the module is either in the 'HomePackageTable' or is
1963 -- a package module with an interface on disk. If neither of these is
1964 -- true, then the result will be an error indicating the interface
1965 -- could not be found.
1966 getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface)
1967 getModuleInterface hsc_env mod
1968 = runTcInteractive hsc_env $
1969 loadModuleInterface (ptext (sLit "getModuleInterface")) mod
1970
1971 tcRnLookupRdrName :: HscEnv -> Located RdrName
1972 -> IO (Messages, Maybe [Name])
1973 -- ^ Find all the Names that this RdrName could mean, in GHCi
1974 tcRnLookupRdrName hsc_env (L loc rdr_name)
1975 = runTcInteractive hsc_env $
1976 setSrcSpan loc $
1977 do { -- If the identifier is a constructor (begins with an
1978 -- upper-case letter), then we need to consider both
1979 -- constructor and type class identifiers.
1980 let rdr_names = dataTcOccs rdr_name
1981 ; names_s <- mapM lookupInfoOccRn rdr_names
1982 ; let names = concat names_s
1983 ; when (null names) (addErrTc (ptext (sLit "Not in scope:") <+> quotes (ppr rdr_name)))
1984 ; return names }
1985 #endif
1986
1987 tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)
1988 tcRnLookupName hsc_env name
1989 = runTcInteractive hsc_env $
1990 tcRnLookupName' name
1991
1992 -- To look up a name we have to look in the local environment (tcl_lcl)
1993 -- as well as the global environment, which is what tcLookup does.
1994 -- But we also want a TyThing, so we have to convert:
1995
1996 tcRnLookupName' :: Name -> TcRn TyThing
1997 tcRnLookupName' name = do
1998 tcthing <- tcLookup name
1999 case tcthing of
2000 AGlobal thing -> return thing
2001 ATcId{tct_id=id} -> return (AnId id)
2002 _ -> panic "tcRnLookupName'"
2003
2004 tcRnGetInfo :: HscEnv
2005 -> Name
2006 -> IO (Messages, Maybe (TyThing, Fixity, [ClsInst], [FamInst]))
2007
2008 -- Used to implement :info in GHCi
2009 --
2010 -- Look up a RdrName and return all the TyThings it might be
2011 -- A capitalised RdrName is given to us in the DataName namespace,
2012 -- but we want to treat it as *both* a data constructor
2013 -- *and* as a type or class constructor;
2014 -- hence the call to dataTcOccs, and we return up to two results
2015 tcRnGetInfo hsc_env name
2016 = runTcInteractive hsc_env $
2017 do { loadUnqualIfaces hsc_env (hsc_IC hsc_env)
2018 -- Load the interface for all unqualified types and classes
2019 -- That way we will find all the instance declarations
2020 -- (Packages have not orphan modules, and we assume that
2021 -- in the home package all relevant modules are loaded.)
2022
2023 ; thing <- tcRnLookupName' name
2024 ; fixity <- lookupFixityRn name
2025 ; (cls_insts, fam_insts) <- lookupInsts thing
2026 ; return (thing, fixity, cls_insts, fam_insts) }
2027
2028 lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst])
2029 lookupInsts (ATyCon tc)
2030 = do { InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods } <- tcGetInstEnvs
2031 ; (pkg_fie, home_fie) <- tcGetFamInstEnvs
2032 -- Load all instances for all classes that are
2033 -- in the type environment (which are all the ones
2034 -- we've seen in any interface file so far)
2035
2036 -- Return only the instances relevant to the given thing, i.e.
2037 -- the instances whose head contains the thing's name.
2038 ; let cls_insts =
2039 [ ispec -- Search all
2040 | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
2041 , instIsVisible vis_mods ispec
2042 , tc_name `elemNameSet` orphNamesOfClsInst ispec ]
2043 ; let fam_insts =
2044 [ fispec
2045 | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie
2046 , tc_name `elemNameSet` orphNamesOfFamInst fispec ]
2047 ; return (cls_insts, fam_insts) }
2048 where
2049 tc_name = tyConName tc
2050
2051 lookupInsts _ = return ([],[])
2052
2053 loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM ()
2054 -- Load the interface for everything that is in scope unqualified
2055 -- This is so that we can accurately report the instances for
2056 -- something
2057 loadUnqualIfaces hsc_env ictxt
2058 = initIfaceTcRn $ do
2059 mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
2060 where
2061 this_pkg = thisPackage (hsc_dflags hsc_env)
2062
2063 unqual_mods = [ nameModule name
2064 | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt)
2065 , let name = gre_name gre
2066 , nameIsFromExternalPackage this_pkg name
2067 , isTcOcc (nameOccName name) -- Types and classes only
2068 , unQualOK gre ] -- In scope unqualified
2069 doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified")
2070
2071
2072 {-
2073 ************************************************************************
2074 * *
2075 Degugging output
2076 * *
2077 ************************************************************************
2078 -}
2079
2080 rnDump :: SDoc -> TcRn ()
2081 -- Dump, with a banner, if -ddump-rn
2082 rnDump doc = do { traceOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
2083
2084 tcDump :: TcGblEnv -> TcRn ()
2085 tcDump env
2086 = do { dflags <- getDynFlags ;
2087
2088 -- Dump short output if -ddump-types or -ddump-tc
2089 when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
2090 (printForUserTcRn short_dump) ;
2091
2092 -- Dump bindings if -ddump-tc
2093 traceOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
2094 }
2095 where
2096 short_dump = pprTcGblEnv env
2097 full_dump = pprLHsBinds (tcg_binds env)
2098 -- NB: foreign x-d's have undefined's in their types;
2099 -- hence can't show the tc_fords
2100
2101 -- It's unpleasant having both pprModGuts and pprModDetails here
2102 pprTcGblEnv :: TcGblEnv -> SDoc
2103 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
2104 tcg_insts = insts,
2105 tcg_fam_insts = fam_insts,
2106 tcg_rules = rules,
2107 tcg_vects = vects,
2108 tcg_imports = imports })
2109 = vcat [ ppr_types insts type_env
2110 , ppr_tycons fam_insts type_env
2111 , ppr_insts insts
2112 , ppr_fam_insts fam_insts
2113 , vcat (map ppr rules)
2114 , vcat (map ppr vects)
2115 , ptext (sLit "Dependent modules:") <+>
2116 ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))
2117 , ptext (sLit "Dependent packages:") <+>
2118 ppr (sortBy stablePackageKeyCmp $ imp_dep_pkgs imports)]
2119 where -- The two uses of sortBy are just to reduce unnecessary
2120 -- wobbling in testsuite output
2121 cmp_mp (mod_name1, is_boot1) (mod_name2, is_boot2)
2122 = (mod_name1 `stableModuleNameCmp` mod_name2)
2123 `thenCmp`
2124 (is_boot1 `compare` is_boot2)
2125
2126 ppr_types :: [ClsInst] -> TypeEnv -> SDoc
2127 ppr_types insts type_env
2128 = text "TYPE SIGNATURES" $$ nest 2 (ppr_sigs ids)
2129 where
2130 dfun_ids = map instanceDFunId insts
2131 ids = [id | id <- typeEnvIds type_env, want_sig id]
2132 want_sig id | opt_PprStyle_Debug = True
2133 | otherwise = isLocalId id &&
2134 isExternalName (idName id) &&
2135 not (id `elem` dfun_ids)
2136 -- isLocalId ignores data constructors, records selectors etc.
2137 -- The isExternalName ignores local dictionary and method bindings
2138 -- that the type checker has invented. Top-level user-defined things
2139 -- have External names.
2140
2141 ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
2142 ppr_tycons fam_insts type_env
2143 = vcat [ text "TYPE CONSTRUCTORS"
2144 , nest 2 (ppr_tydecls tycons)
2145 , text "COERCION AXIOMS"
2146 , nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ]
2147 where
2148 fi_tycons = famInstsRepTyCons fam_insts
2149 tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon]
2150 want_tycon tycon | opt_PprStyle_Debug = True
2151 | otherwise = not (isImplicitTyCon tycon) &&
2152 isExternalName (tyConName tycon) &&
2153 not (tycon `elem` fi_tycons)
2154
2155 ppr_insts :: [ClsInst] -> SDoc
2156 ppr_insts [] = empty
2157 ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
2158
2159 ppr_fam_insts :: [FamInst] -> SDoc
2160 ppr_fam_insts [] = empty
2161 ppr_fam_insts fam_insts =
2162 text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts)
2163
2164 ppr_sigs :: [Var] -> SDoc
2165 ppr_sigs ids
2166 -- Print type signatures; sort by OccName
2167 = vcat (map ppr_sig (sortBy (comparing getOccName) ids))
2168 where
2169 ppr_sig id = hang (ppr id <+> dcolon) 2 (ppr (tidyTopType (idType id)))
2170
2171 ppr_tydecls :: [TyCon] -> SDoc
2172 ppr_tydecls tycons
2173 -- Print type constructor info; sort by OccName
2174 = vcat (map ppr_tycon (sortBy (comparing getOccName) tycons))
2175 where
2176 ppr_tycon tycon = vcat [ ppr (tyThingToIfaceDecl (ATyCon tycon)) ]
2177
2178 {-
2179 ********************************************************************************
2180
2181 Type Checker Plugins
2182
2183 ********************************************************************************
2184 -}
2185
2186 withTcPlugins :: HscEnv -> TcM a -> TcM a
2187 withTcPlugins hsc_env m =
2188 do plugins <- liftIO (loadTcPlugins hsc_env)
2189 case plugins of
2190 [] -> m -- Common fast case
2191 _ -> do (solvers,stops) <- unzip `fmap` mapM startPlugin plugins
2192 -- This ensures that tcPluginStop is called even if a type
2193 -- error occurs during compilation (Fix of #10078)
2194 eitherRes <- tryM $ do
2195 updGblEnv (\e -> e { tcg_tc_plugins = solvers }) m
2196 mapM_ (flip runTcPluginM Nothing) stops
2197 case eitherRes of
2198 Left _ -> failM
2199 Right res -> return res
2200 where
2201 startPlugin (TcPlugin start solve stop) =
2202 do s <- runTcPluginM start Nothing
2203 return (solve s, stop s)
2204
2205 loadTcPlugins :: HscEnv -> IO [TcPlugin]
2206 #ifndef GHCI
2207 loadTcPlugins _ = return []
2208 #else
2209 loadTcPlugins hsc_env =
2210 do named_plugins <- loadPlugins hsc_env
2211 return $ catMaybes $ map load_plugin named_plugins
2212 where
2213 load_plugin (_, plug, opts) = tcPlugin plug opts
2214 #endif