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