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