2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcModule]{Typechecking a whole module}
8 typecheckModule, typecheckIface, typecheckStmt, typecheckExpr,
13 #include "HsVersions.h"
15 import CmdLineOpts ( DynFlag(..), DynFlags, dopt )
16 import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
17 Stmt(..), InPat(..), HsMatchContext(..), HsDoContext(..), RuleDecl(..),
18 isSourceInstDecl, nullBinds, mkSimpleMatch, placeHolderType
20 import PrelNames ( mAIN_Name, mainName, ioTyConName, printName,
21 returnIOName, bindIOName, failIOName,
24 import MkId ( unsafeCoerceId )
25 import RnHsSyn ( RenamedHsBinds, RenamedHsDecl, RenamedStmt,
26 RenamedHsExpr, RenamedRuleDecl, RenamedTyClDecl, RenamedInstDecl )
27 import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr,
28 TypecheckedForeignDecl, TypecheckedRuleDecl,
29 zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet,
33 import MkIface ( pprModDetails )
34 import TcExpr ( tcMonoExpr )
36 import TcMType ( newTyVarTy, zonkTcType, tcInstType )
37 import TcType ( Type, liftedTypeKind, openTypeKind,
38 tyVarsOfType, tidyType, tcFunResultTy,
39 mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys
41 import TcMatches ( tcStmtsAndThen )
42 import Inst ( emptyLIE, plusLIE )
43 import TcBinds ( tcTopBinds )
44 import TcClassDcl ( tcClassDecls2 )
45 import TcDefaults ( tcDefaults, defaultDefaultTys )
46 import TcEnv ( TcEnv, RecTcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv, tcLookup_maybe,
47 isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv,
48 tcExtendGlobalEnv, tcExtendGlobalTypeEnv,
49 tcLookupGlobalId, tcLookupTyCon,
50 TcTyThing(..), TyThing(..), tcLookupId
52 import TcRules ( tcIfaceRules, tcSourceRules )
53 import TcForeign ( tcForeignImports, tcForeignExports )
54 import TcIfaceSig ( tcInterfaceSigs )
55 import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls1, addInstDFuns, tcInstDecls2 )
56 import TcUnify ( unifyTauTy )
57 import TcSimplify ( tcSimplifyTop, tcSimplifyInfer )
58 import TcTyClsDecls ( tcTyAndClassDecls )
59 import CoreUnfold ( unfoldingTemplate )
60 import TysWiredIn ( mkListTy, unitTy )
61 import ErrUtils ( printErrorsAndWarnings, errorsFound,
62 dumpIfSet_dyn, dumpIfSet_dyn_or, showPass )
63 import Rules ( extendRuleBase )
64 import Id ( Id, idType, idUnfolding )
65 import Module ( Module, moduleName )
67 import NameEnv ( lookupNameEnv )
68 import TyCon ( tyConGenInfo )
69 import BasicTypes ( EP(..), Fixity, RecFlag(..) )
70 import SrcLoc ( noSrcLoc )
73 import HscTypes ( PersistentCompilerState(..), HomeSymbolTable,
74 PackageTypeEnv, ModIface(..),
75 ModDetails(..), DFunId,
76 TypeEnv, extendTypeEnvList, typeEnvTyCons, typeEnvElts,
79 import List ( partition )
83 %************************************************************************
85 \subsection{The stmt interface}
87 %************************************************************************
92 -> PersistentCompilerState
94 -> TypeEnv -- The interactive context's type envt
95 -> PrintUnqualified -- For error printing
96 -> Module -- Is this really needed
97 -> [Name] -- Names bound by the Stmt (empty for expressions)
98 -> (RenamedStmt, -- The stmt itself
99 [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files
100 -> IO (Maybe (PersistentCompilerState,
104 -- The returned [Id] is the same as the input except for
105 -- ExprStmt, in which case the returned [Name] is [itName]
107 typecheckStmt dflags pcs hst ic_type_env unqual this_mod names (stmt, iface_decls)
108 = typecheck dflags pcs hst unqual $
110 -- use the default default settings, i.e. [Integer, Double]
111 tcSetDefaultTys defaultDefaultTys $
113 -- Typecheck the extra declarations
114 tcExtraDecls pcs this_mod iface_decls `thenTc` \ (new_pcs, env) ->
117 tcExtendGlobalTypeEnv ic_type_env $
119 -- The real work is done here
120 tcUserStmt names stmt `thenTc` \ (expr, bound_ids) ->
122 traceTc (text "tcs 1") `thenNF_Tc_`
123 zonkExpr expr `thenNF_Tc` \ zonked_expr ->
124 mapNF_Tc zonkIdBndr bound_ids `thenNF_Tc` \ zonked_ids ->
126 ioToTc (dumpIfSet_dyn dflags Opt_D_dump_tc "Bound Ids" (vcat (map ppr zonked_ids))) `thenNF_Tc_`
127 ioToTc (dumpIfSet_dyn dflags Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_`
129 returnTc (new_pcs, zonked_expr, zonked_ids, error "typecheckStmt: no type")
132 Here is the grand plan, implemented in tcUserStmt
134 What you type The IO [HValue] that hscStmt returns
135 ------------- ------------------------------------
136 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
139 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
142 expr (of IO type) ==> expr >>= \ v -> return [v]
143 [NB: result not printed] bindings: [it]
146 expr (of non-IO type,
147 result showable) ==> let v = expr in print v >> return [v]
150 expr (of non-IO type,
151 result not showable) ==> error
155 tcUserStmt :: [Name] -> RenamedStmt -> TcM (TypecheckedHsExpr, [Id])
157 tcUserStmt names (ExprStmt expr _ loc)
158 = ASSERT( null names )
159 tcGetUnique `thenNF_Tc` \ uniq ->
161 fresh_it = itName uniq
162 the_bind = FunMonoBind fresh_it False
163 [ mkSimpleMatch [] expr placeHolderType loc ] loc
165 tryTc_ (traceTc (text "tcs 1b") `thenNF_Tc_`
166 tc_stmts [fresh_it] [
167 LetStmt (MonoBind the_bind [] NonRecursive),
168 ExprStmt (HsApp (HsVar printName) (HsVar fresh_it)) placeHolderType loc])
169 ( traceTc (text "tcs 1a") `thenNF_Tc_`
170 tc_stmts [fresh_it] [BindStmt (VarPatIn fresh_it) expr loc])
172 tcUserStmt names stmt
173 = tc_stmts names [stmt]
177 = tcLookupGlobalId returnIOName `thenNF_Tc` \ return_id ->
178 tcLookupGlobalId bindIOName `thenNF_Tc` \ bind_id ->
179 tcLookupGlobalId failIOName `thenNF_Tc` \ fail_id ->
180 tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon ->
181 newTyVarTy liftedTypeKind `thenNF_Tc` \ res_ty ->
183 io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty)
185 -- mk_return builds the expression
186 -- returnIO @ [()] [coerce () x, .., coerce () z]
187 mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy])
188 (ExplicitList unitTy (map mk_item ids))
190 mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy])
194 traceTc (text "tcs 2") `thenNF_Tc_`
195 tcStmtsAndThen combine (DoCtxt DoExpr) io_ty stmts (
196 -- Look up the names right in the middle,
197 -- where they will all be in scope
198 mapNF_Tc tcLookupId names `thenNF_Tc` \ ids ->
199 returnTc ((ids, [ResultStmt (mk_return ids) noSrcLoc]), emptyLIE)
200 ) `thenTc` \ ((ids, tc_stmts), lie) ->
202 -- Simplify the context right here, so that we fail
203 -- if there aren't enough instances. Notably, when we see
205 -- we use tryTc_ to try it <- e
206 -- and then let it = e
207 -- It's the simplify step that rejects the first.
209 traceTc (text "tcs 3") `thenNF_Tc_`
210 tcSimplifyTop lie `thenTc` \ const_binds ->
211 traceTc (text "tcs 4") `thenNF_Tc_`
213 returnTc (mkHsLet const_binds $
214 HsDoOut DoExpr tc_stmts return_id bind_id fail_id
215 (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc,
218 combine stmt (ids, stmts) = (ids, stmt:stmts)
221 %************************************************************************
223 \subsection{Typechecking an expression}
225 %************************************************************************
228 typecheckExpr :: DynFlags
229 -> PersistentCompilerState
231 -> TypeEnv -- The interactive context's type envt
232 -> PrintUnqualified -- For error printing
234 -> (RenamedHsExpr, -- The expression itself
235 [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files
236 -> IO (Maybe (PersistentCompilerState,
238 [Id], -- always empty (matches typecheckStmt)
241 typecheckExpr dflags pcs hst ic_type_env unqual this_mod (expr, decls)
242 = typecheck dflags pcs hst unqual $
244 -- use the default default settings, i.e. [Integer, Double]
245 tcSetDefaultTys defaultDefaultTys $
247 -- Typecheck the extra declarations
248 tcExtraDecls pcs this_mod decls `thenTc` \ (new_pcs, env) ->
250 -- Now typecheck the expression
252 tcExtendGlobalTypeEnv ic_type_env $
254 newTyVarTy openTypeKind `thenTc` \ ty ->
255 tcMonoExpr expr ty `thenTc` \ (e', lie) ->
256 tcSimplifyInfer smpl_doc (tyVarsOfType ty) lie
257 `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) ->
258 tcSimplifyTop lie_free `thenTc` \ const_binds ->
260 let all_expr = mkHsLet const_binds $
266 all_expr_ty = mkForAllTys qtvs $
267 mkFunTys (map idType dict_ids) $
271 zonkExpr all_expr `thenNF_Tc` \ zonked_expr ->
272 zonkTcType all_expr_ty `thenNF_Tc` \ zonked_ty ->
273 ioToTc (dumpIfSet_dyn dflags
274 Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_`
275 returnTc (new_pcs, zonked_expr, [], zonked_ty)
278 smpl_doc = ptext SLIT("main expression")
281 %************************************************************************
283 \subsection{Typechecking extra declarations}
285 %************************************************************************
290 -> PersistentCompilerState
292 -> PrintUnqualified -- For error printing
293 -> Module -- Is this really needed
294 -> [RenamedHsDecl] -- extra decls sucked in from interface files
295 -> IO (Maybe PersistentCompilerState)
297 typecheckExtraDecls dflags pcs hst unqual this_mod decls
298 = typecheck dflags pcs hst unqual $
299 tcExtraDecls pcs this_mod decls `thenTc` \ (new_pcs, _) ->
302 tcExtraDecls :: PersistentCompilerState
305 -> TcM (PersistentCompilerState, TcEnv)
307 tcExtraDecls pcs this_mod decls
308 = tcIfaceImports this_mod decls `thenTc` \ (env, all_things, dfuns, rules) ->
309 addInstDFuns (pcs_insts pcs) dfuns `thenNF_Tc` \ new_pcs_insts ->
311 new_pcs_pte = extendTypeEnvList (pcs_PTE pcs) all_things
312 new_pcs_rules = addIfaceRules (pcs_rules pcs) rules
314 new_pcs :: PersistentCompilerState
315 new_pcs = pcs { pcs_PTE = new_pcs_pte,
316 pcs_insts = new_pcs_insts,
317 pcs_rules = new_pcs_rules
320 -- Add the new instances
321 tcSetEnv env (tcSetInstEnv new_pcs_insts tcGetEnv) `thenNF_Tc` \ new_env ->
322 returnTc (new_pcs, new_env)
326 %************************************************************************
328 \subsection{Typechecking a module}
330 %************************************************************************
335 -> PersistentCompilerState
337 -> ModIface -- Iface for this module
338 -> PrintUnqualified -- For error printing
340 -> IO (Maybe (PersistentCompilerState, TcResults))
341 -- The new PCS is Augmented with imported information,
342 -- (but not stuff from this module)
346 -- All these fields have info *just for this module*
347 tc_env :: TypeEnv, -- The top level TypeEnv
348 tc_insts :: [DFunId], -- Instances
349 tc_rules :: [TypecheckedRuleDecl], -- Transformation rules
350 tc_binds :: TypecheckedMonoBinds, -- Bindings
351 tc_fords :: [TypecheckedForeignDecl] -- Foreign import & exports.
355 typecheckModule dflags pcs hst mod_iface unqual decls
356 = do { maybe_tc_result <- typecheck dflags pcs hst unqual $
357 tcModule pcs hst get_fixity this_mod decls
358 ; printTcDump dflags unqual maybe_tc_result
359 ; return maybe_tc_result }
361 this_mod = mi_module mod_iface
362 fixity_env = mi_fixities mod_iface
364 get_fixity :: Name -> Maybe Fixity
365 get_fixity nm = lookupNameEnv fixity_env nm
368 tcModule :: PersistentCompilerState
370 -> (Name -> Maybe Fixity)
373 -> TcM (PersistentCompilerState, TcResults)
375 tcModule pcs hst get_fixity this_mod decls
376 = fixTc (\ ~(unf_env, _, _) ->
377 -- Loop back the final environment, including the fully zonked
378 -- versions of bindings from this module. In the presence of mutual
379 -- recursion, interface type signatures may mention variables defined
380 -- in this module, which is why the knot is so big
382 -- Type-check the type and class decls, and all imported decls
383 tcImports unf_env pcs hst get_fixity this_mod
384 tycl_decls iface_inst_decls iface_rule_decls `thenTc` \ (env1, new_pcs) ->
388 -- Do the source-language instances, including derivings
389 tcInstDecls1 new_pcs hst unf_env
391 tycl_decls src_inst_decls `thenTc` \ (inst_env, inst_info, deriv_binds) ->
392 tcSetInstEnv inst_env $
394 -- Foreign import declarations next
395 traceTc (text "Tc4") `thenNF_Tc_`
396 tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) ->
397 tcExtendGlobalValEnv fo_ids $
399 -- Default declarations
400 tcDefaults decls `thenTc` \ defaulting_tys ->
401 tcSetDefaultTys defaulting_tys $
403 -- Value declarations next.
404 -- We also typecheck any extra binds that came out of the "deriving" process
405 traceTc (text "Default types" <+> ppr defaulting_tys) `thenNF_Tc_`
406 traceTc (text "Tc5") `thenNF_Tc_`
407 tcTopBinds (val_binds `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env2), lie_valdecls) ->
409 -- Second pass over class and instance declarations,
410 -- plus rules and foreign exports, to generate bindings
412 traceTc (text "Tc6") `thenNF_Tc_`
413 traceTc (ppr (getTcGEnv env2)) `thenNF_Tc_`
414 tcClassDecls2 this_mod tycl_decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds, dm_ids) ->
415 tcExtendGlobalValEnv dm_ids $
416 traceTc (text "Tc7") `thenNF_Tc_`
417 tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
418 traceTc (text "Tc8") `thenNF_Tc_`
419 tcForeignExports decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) ->
420 traceTc (text "Tc9") `thenNF_Tc_`
421 tcSourceRules src_rule_decls `thenNF_Tc` \ (lie_rules, src_rules) ->
423 -- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED
424 traceTc (text "Tc10") `thenNF_Tc_`
425 tcCheckMain this_mod `thenTc_`
427 -- Deal with constant or ambiguous InstIds. How could
428 -- there be ambiguous ones? They can only arise if a
429 -- top-level decl falls under the monomorphism
430 -- restriction, and no subsequent decl instantiates its
431 -- type. (Usually, ambiguous type variables are resolved
432 -- during the generalisation step.)
434 -- Note that we must do this *after* tcCheckMain, because of the
435 -- following bizarre case:
437 -- Here, we infer main :: forall a. m a, where m is a free
438 -- type variable. tcCheckMain will unify it with IO, and that
439 -- must happen before tcSimplifyTop, since the latter will report
442 lie_alldecls = lie_valdecls `plusLIE`
443 lie_instdecls `plusLIE`
444 lie_clasdecls `plusLIE`
445 lie_fodecls `plusLIE`
448 tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds ->
449 traceTc (text "endsimpltop") `thenTc_`
451 -- Backsubstitution. This must be done last.
452 -- Even tcSimplifyTop may do some unification.
454 all_binds = val_binds `AndMonoBinds`
455 inst_binds `AndMonoBinds`
456 cls_dm_binds `AndMonoBinds`
457 const_inst_binds `AndMonoBinds`
460 traceTc (text "Tc7") `thenNF_Tc_`
461 zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', final_env) ->
463 -- zonkTopBinds puts all the top-level Ids into the tcGEnv
464 traceTc (text "Tc8") `thenNF_Tc_`
465 zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' ->
466 traceTc (text "Tc9") `thenNF_Tc_`
467 zonkRules src_rules `thenNF_Tc` \ src_rules' ->
470 let src_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv final_env))
471 -- This is horribly crude; the env might be jolly big
473 traceTc (text "Tc10") `thenNF_Tc_`
476 TcResults { tc_env = mkTypeEnv src_things,
477 tc_insts = map iDFunId inst_info,
478 tc_binds = all_binds',
479 tc_fords = foi_decls ++ foe_decls',
480 tc_rules = src_rules'
483 ) `thenTc` \ (_, pcs, tc_result) ->
484 returnTc (pcs, tc_result)
486 tycl_decls = [d | TyClD d <- decls]
487 rule_decls = [d | RuleD d <- decls]
488 inst_decls = [d | InstD d <- decls]
489 val_decls = [d | ValD d <- decls]
491 (src_inst_decls, iface_inst_decls) = partition isSourceInstDecl inst_decls
492 (src_rule_decls, iface_rule_decls) = partition (isSourceRuleDecl this_mod) rule_decls
493 val_binds = foldr ThenBinds EmptyBinds val_decls
497 %************************************************************************
499 \subsection{Typechecking interface decls}
501 %************************************************************************
506 -> PersistentCompilerState
508 -> ModIface -- Iface for this module (just module & fixities)
510 -> IO (Maybe (PersistentCompilerState, ModDetails))
511 -- The new PCS is Augmented with imported information,
512 -- (but not stuff from this module).
514 typecheckIface dflags pcs hst mod_iface decls
515 = do { maybe_tc_stuff <- typecheck dflags pcs hst alwaysQualify $
516 tcIface pcs this_mod decls
517 ; printIfaceDump dflags maybe_tc_stuff
518 ; return maybe_tc_stuff }
520 this_mod = mi_module mod_iface
522 tcIface pcs this_mod decls
523 -- The decls are coming from this_mod's interface file, together
524 -- with imported interface decls that belong in the "package" stuff.
525 -- (With GHCi, all the home modules have already been processed.)
526 -- That is why we need to do the partitioning below.
527 = tcIfaceImports this_mod decls `thenTc` \ (_, all_things, dfuns, rules) ->
530 -- Do the partitioning (see notes above)
531 (local_things, imported_things) = partition (isLocalThing this_mod) all_things
532 (local_rules, imported_rules) = partition is_local_rule rules
533 (local_dfuns, imported_dfuns) = partition (isLocalThing this_mod) dfuns
534 is_local_rule (IfaceRuleOut n _) = isLocalThing this_mod n
536 addInstDFuns (pcs_insts pcs) imported_dfuns `thenNF_Tc` \ new_pcs_insts ->
538 new_pcs_pte :: PackageTypeEnv
539 new_pcs_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
540 new_pcs_rules = addIfaceRules (pcs_rules pcs) imported_rules
542 new_pcs :: PersistentCompilerState
543 new_pcs = pcs { pcs_PTE = new_pcs_pte,
544 pcs_insts = new_pcs_insts,
545 pcs_rules = new_pcs_rules
548 mod_details = ModDetails { md_types = mkTypeEnv local_things,
549 md_insts = local_dfuns,
550 md_rules = [(id,rule) | IfaceRuleOut id rule <- local_rules],
552 -- All the rules from an interface are of the IfaceRuleOut form
554 returnTc (new_pcs, mod_details)
557 tcIfaceImports :: Module
558 -> [RenamedHsDecl] -- All interface-file decls
559 -> TcM (TcEnv, [TyThing], [DFunId], [TypecheckedRuleDecl])
560 tcIfaceImports this_mod decls
561 -- The decls are all interface-file declarations
563 inst_decls = [d | InstD d <- decls]
564 tycl_decls = [d | TyClD d <- decls]
565 rule_decls = [d | RuleD d <- decls]
567 fixTc (\ ~(unf_env, _, _, _) ->
568 -- This fixTc follows the same general plan as tcImports,
569 -- which is better commented (below)
570 tcTyAndClassDecls unf_env this_mod tycl_decls `thenTc` \ tycl_things ->
571 tcExtendGlobalEnv tycl_things $
572 tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
573 tcExtendGlobalValEnv sig_ids $
574 tcIfaceInstDecls1 inst_decls `thenTc` \ dfuns ->
575 tcIfaceRules rule_decls `thenTc` \ rules ->
576 tcGetEnv `thenTc` \ env ->
578 all_things = map AnId sig_ids ++ tycl_things
580 returnTc (env, all_things, dfuns, rules)
584 tcImports :: RecTcEnv
585 -> PersistentCompilerState
587 -> (Name -> Maybe Fixity)
592 -> TcM (TcEnv, PersistentCompilerState)
594 -- tcImports is a slight mis-nomer.
595 -- It deals with everything that could be an import:
596 -- type and class decls (some source, some imported)
597 -- interface signatures (checked lazily)
598 -- instance decls (some source, some imported)
599 -- rule decls (all imported)
600 -- These can occur in source code too, of course
602 -- tcImports is only called when processing source code,
603 -- so that any interface-file declarations are for other modules, not this one
605 tcImports unf_env pcs hst get_fixity this_mod
606 tycl_decls inst_decls rule_decls
607 -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
608 -- which is done lazily [ie failure just drops the pragma
609 -- without having any global-failure effect].
611 -- unf_env is also used to get the pragama info
612 -- for imported dfuns and default methods
615 -- tcImports recovers internally, but if anything gave rise to
616 -- an error we'd better stop now, to avoid a cascade
618 traceTc (text "Tc1") `thenNF_Tc_`
619 tcTyAndClassDecls unf_env this_mod tycl_decls `thenTc` \ tycl_things ->
620 tcExtendGlobalEnv tycl_things $
622 -- Interface type signatures
623 -- We tie a knot so that the Ids read out of interfaces are in scope
624 -- when we read their pragmas.
625 -- What we rely on is that pragmas are typechecked lazily; if
626 -- any type errors are found (ie there's an inconsistency)
627 -- we silently discard the pragma
628 traceTc (text "Tc2") `thenNF_Tc_`
629 tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
630 tcExtendGlobalValEnv sig_ids $
632 -- Typecheck the instance decls, includes deriving
633 -- Note that imported dictionary functions are already
634 -- in scope from the preceding tcInterfaceSigs
635 traceTc (text "Tc3") `thenNF_Tc_`
636 tcIfaceInstDecls1 inst_decls `thenTc` \ dfuns ->
637 tcIfaceRules rule_decls `thenNF_Tc` \ rules ->
639 addInstDFuns (pcs_insts pcs) dfuns `thenNF_Tc` \ new_pcs_insts ->
640 tcGetEnv `thenTc` \ unf_env ->
642 -- sometimes we're compiling in the context of a package module
643 -- (on the GHCi command line, for example). In this case, we
644 -- want to treat everything we pulled in as an imported thing.
645 imported_things = map AnId sig_ids ++ -- All imported
646 filter (not . isLocalThing this_mod) tycl_things
648 new_pte :: PackageTypeEnv
649 new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
651 new_pcs_rules = addIfaceRules (pcs_rules pcs) rules
653 new_pcs :: PersistentCompilerState
654 new_pcs = pcs { pcs_PTE = new_pte,
655 pcs_insts = new_pcs_insts,
656 pcs_rules = new_pcs_rules
659 returnTc (unf_env, new_pcs)
661 isSourceRuleDecl :: Module -> RenamedRuleDecl -> Bool
662 -- This is a bit gruesome.
663 -- Usually, HsRules come only from source files; IfaceRules only from interface files
664 -- But built-in rules appear as an IfaceRuleOut... and when compiling
665 -- the source file for that built-in rule, we want to treat it as a source
666 -- rule, so it gets put with the other rules for that module.
667 isSourceRuleDecl this_mod (HsRule _ _ _ _ _ _) = True
668 isSourceRuleDecl this_mod (IfaceRule _ _ _ n _ _ _) = False
669 isSourceRuleDecl this_mod (IfaceRuleOut name _) = isLocalThing this_mod name
671 addIfaceRules rule_base rules
672 = foldl add_rule rule_base rules
674 add_rule rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule)
678 %************************************************************************
680 \subsection{Checking the type of main}
682 %************************************************************************
684 We must check that in module Main,
686 b) main :: forall a1...an. IO t, for some type t
690 then the type of main will be
692 and that should pass the test too.
694 So we just instantiate the type and unify with IO t, and declare
695 victory if doing so succeeds.
698 tcCheckMain :: Module -> TcM ()
700 | not (moduleName this_mod == mAIN_Name )
704 = -- First unify the main_id with IO t, for any old t
705 tcLookup_maybe mainName `thenNF_Tc` \ maybe_thing ->
707 Just (ATcId main_id) -> check_main_ty (idType main_id)
708 other -> addErrTc noMainErr
710 check_main_ty main_ty
711 = tcInstType main_ty `thenNF_Tc` \ (tvs, theta, main_tau) ->
712 newTyVarTy liftedTypeKind `thenNF_Tc` \ arg_ty ->
713 tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon ->
714 tcAddErrCtxtM (mainTypeCtxt main_ty) $
715 if not (null theta) then
716 failWithTc empty -- Context has the error message
718 unifyTauTy main_tau (mkTyConApp ioTyCon [arg_ty])
720 mainTypeCtxt main_ty tidy_env
721 = zonkTcType main_ty `thenNF_Tc` \ main_ty' ->
722 returnNF_Tc (tidy_env, ptext SLIT("`main' has the illegal type") <+>
723 quotes (ppr (tidyType tidy_env main_ty')))
725 noMainErr = hsep [ptext SLIT("Module") <+> quotes (ppr mAIN_Name),
726 ptext SLIT("must include a definition for") <+> quotes (ptext SLIT("main"))]
730 %************************************************************************
732 \subsection{Interfacing the Tc monad to the IO monad}
734 %************************************************************************
737 typecheck :: DynFlags
738 -> PersistentCompilerState
740 -> PrintUnqualified -- For error printing
744 typecheck dflags pcs hst unqual thing_inside
745 = do { showPass dflags "Typechecker";
746 ; env <- initTcEnv hst (pcs_PTE pcs)
748 ; (maybe_tc_result, errs) <- initTc dflags env thing_inside
750 ; printErrorsAndWarnings unqual errs
752 ; if errorsFound errs then
755 return maybe_tc_result
760 %************************************************************************
762 \subsection{Dumping output}
764 %************************************************************************
767 printTcDump dflags unqual Nothing = return ()
768 printTcDump dflags unqual (Just (_, results))
769 = do if dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags then
770 printForUser stdout unqual (dump_tc_iface dflags results)
773 dumpIfSet_dyn dflags Opt_D_dump_tc
774 "Typechecked" (ppr (tc_binds results))
777 printIfaceDump dflags Nothing = return ()
778 printIfaceDump dflags (Just (_, details))
779 = dumpIfSet_dyn_or dflags [Opt_D_dump_types, Opt_D_dump_tc]
780 "Interface" (pprModDetails details)
782 dump_tc_iface dflags results
783 = vcat [pprModDetails (ModDetails {md_types = tc_env results,
784 md_insts = tc_insts results,
785 md_rules = [], md_binds = []}) ,
786 ppr_rules (tc_rules results),
788 if dopt Opt_Generics dflags then
789 ppr_gen_tycons (typeEnvTyCons (tc_env results))
795 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
796 nest 4 (vcat (map ppr rs)),
799 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
800 vcat (map ppr_gen_tycon tcs),
804 -- x&y are now Id's, not CoreExpr's
806 | Just ep <- tyConGenInfo tycon
807 = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
809 | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
812 = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
813 ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
814 ptext SLIT("To:") <+> ppr (unfoldingTemplate (idUnfolding to))
817 (_,from_tau) = tcSplitForAllTys (idType from)