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