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