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