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