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