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