2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcModule]{Typechecking a whole module}
8 typecheckModule, typecheckIface, typecheckStmt, typecheckExpr,
9 typecheckExtraDecls, typecheckCoreModule,
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, mkSimpleMatch, placeHolderType, isCoreDecl
20 import PrelNames ( ioTyConName, printName,
21 returnIOName, bindIOName, failIOName, thenIOName, runIOName,
22 dollarMainName, itName
24 import MkId ( unsafeCoerceId )
25 import RnHsSyn ( RenamedHsDecl, RenamedStmt, RenamedHsExpr,
26 RenamedRuleDecl, RenamedTyClDecl, RenamedInstDecl )
27 import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr,
28 TypecheckedForeignDecl, TypecheckedRuleDecl,
30 zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet,
34 import Rename ( RnResult(..) )
35 import MkIface ( pprModDetails )
36 import TcExpr ( tcMonoExpr )
38 import TcMType ( newTyVarTy, zonkTcType )
39 import TcType ( Type, liftedTypeKind, openTypeKind,
40 tyVarsOfType, tcFunResultTy,
41 mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys,
42 tcSplitTyConApp_maybe, isUnitTy
44 import TcMatches ( tcStmtsAndThen )
45 import Inst ( LIE, emptyLIE, plusLIE )
46 import TcBinds ( tcTopBinds )
47 import TcClassDcl ( tcClassDecls2 )
48 import TcDefaults ( tcDefaults, defaultDefaultTys )
49 import TcEnv ( TcEnv, RecTcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv,
50 isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv,
51 tcExtendGlobalEnv, tcExtendGlobalTypeEnv,
52 tcLookupGlobalId, tcLookupTyCon,
53 TyThing(..), tcLookupId
55 import TcRules ( tcIfaceRules, tcSourceRules )
56 import TcForeign ( tcForeignImports, tcForeignExports )
57 import TcIfaceSig ( tcInterfaceSigs, tcCoreBinds )
58 import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls1, addInstDFuns, initInstEnv, tcInstDecls2 )
59 import TcSimplify ( tcSimplifyTop, tcSimplifyInfer )
60 import TcTyClsDecls ( tcTyAndClassDecls )
61 import CoreUnfold ( unfoldingTemplate )
62 import TysWiredIn ( mkListTy, unitTy )
63 import ErrUtils ( printErrorsAndWarnings, errorsFound,
64 dumpIfSet_dyn, dumpIfSet_dyn_or, showPass )
65 import Rules ( extendRuleBase )
66 import Id ( Id, mkLocalId, idType, idUnfolding, setIdLocalExported )
67 import Module ( Module )
68 import Name ( Name, getName, getSrcLoc )
69 import TyCon ( tyConGenInfo )
70 import BasicTypes ( EP(..), RecFlag(..) )
71 import SrcLoc ( noSrcLoc )
74 import HscTypes ( PersistentCompilerState(..), HomeSymbolTable,
75 PackageTypeEnv, ModIface(..),
76 ModDetails(..), DFunId,
77 TypeEnv, extendTypeEnvList, typeEnvTyCons, typeEnvElts,
80 import List ( partition )
84 %************************************************************************
86 \subsection{The stmt interface}
88 %************************************************************************
93 -> PersistentCompilerState
95 -> TypeEnv -- The interactive context's type envt
96 -> PrintUnqualified -- For error printing
97 -> Module -- Is this really needed
98 -> [Name] -- Names bound by the Stmt (empty for expressions)
99 -> (RenamedStmt, -- The stmt itself
100 [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files
101 -> IO (Maybe (PersistentCompilerState,
105 -- The returned [Id] is the same as the input except for
106 -- ExprStmt, in which case the returned [Name] is [itName]
108 typecheckStmt dflags pcs hst ic_type_env unqual this_mod names (stmt, iface_decls)
109 = typecheck dflags pcs hst unqual $
111 -- use the default default settings, i.e. [Integer, Double]
112 tcSetDefaultTys defaultDefaultTys $
114 -- Typecheck the extra declarations
115 tcExtraDecls pcs hst this_mod iface_decls `thenTc` \ (new_pcs, env) ->
118 tcExtendGlobalTypeEnv ic_type_env $
120 -- The real work is done here
121 tcUserStmt names stmt `thenTc` \ (expr, bound_ids) ->
123 traceTc (text "tcs 1") `thenNF_Tc_`
124 zonkExpr expr `thenNF_Tc` \ zonked_expr ->
125 mapNF_Tc zonkIdBndr bound_ids `thenNF_Tc` \ zonked_ids ->
127 ioToTc (dumpIfSet_dyn dflags Opt_D_dump_tc "Bound Ids" (vcat (map ppr zonked_ids))) `thenNF_Tc_`
128 ioToTc (dumpIfSet_dyn dflags Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_`
130 returnTc (new_pcs, zonked_expr, zonked_ids, error "typecheckStmt: no type")
133 Here is the grand plan, implemented in tcUserStmt
135 What you type The IO [HValue] that hscStmt returns
136 ------------- ------------------------------------
137 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
140 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
143 expr (of IO type) ==> expr >>= \ v -> return [v]
144 [NB: result not printed] bindings: [it]
147 expr (of non-IO type,
148 result showable) ==> let v = expr in print v >> return [v]
151 expr (of non-IO type,
152 result not showable) ==> error
156 tcUserStmt :: [Name] -> RenamedStmt -> TcM (TypecheckedHsExpr, [Id])
158 tcUserStmt names (ExprStmt expr _ loc)
159 = ASSERT( null names )
160 tcGetUnique `thenNF_Tc` \ uniq ->
162 fresh_it = itName uniq
163 the_bind = FunMonoBind fresh_it False
164 [ mkSimpleMatch [] expr placeHolderType loc ] loc
166 tryTc_ (traceTc (text "tcs 1b") `thenNF_Tc_`
167 tc_stmts [fresh_it] [
168 LetStmt (MonoBind the_bind [] NonRecursive),
169 ExprStmt (HsApp (HsVar printName) (HsVar fresh_it)) placeHolderType loc])
170 ( traceTc (text "tcs 1a") `thenNF_Tc_`
171 tc_stmts [fresh_it] [BindStmt (VarPatIn fresh_it) expr loc])
173 tcUserStmt names stmt
174 = tc_stmts names [stmt]
178 = mapNF_Tc tcLookupGlobalId
179 [returnIOName, failIOName, bindIOName, thenIOName] `thenNF_Tc` \ io_ids ->
180 tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon ->
181 newTyVarTy liftedTypeKind `thenNF_Tc` \ res_ty ->
183 return_id = head io_ids -- Rather gruesome
185 io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty)
187 -- mk_return builds the expression
188 -- returnIO @ [()] [coerce () x, .., coerce () z]
189 mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy])
190 (ExplicitList unitTy (map mk_item ids))
192 mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy])
196 traceTc (text "tcs 2") `thenNF_Tc_`
197 tcStmtsAndThen combine (DoCtxt DoExpr) io_ty stmts (
198 -- Look up the names right in the middle,
199 -- where they will all be in scope
200 mapNF_Tc tcLookupId names `thenNF_Tc` \ ids ->
201 returnTc ((ids, [ResultStmt (mk_return ids) noSrcLoc]), emptyLIE)
202 ) `thenTc` \ ((ids, tc_stmts), lie) ->
204 -- Simplify the context right here, so that we fail
205 -- if there aren't enough instances. Notably, when we see
207 -- we use tryTc_ to try it <- e
208 -- and then let it = e
209 -- It's the simplify step that rejects the first.
211 traceTc (text "tcs 3") `thenNF_Tc_`
212 tcSimplifyTop lie `thenTc` \ const_binds ->
213 traceTc (text "tcs 4") `thenNF_Tc_`
215 returnTc (mkHsLet const_binds $
216 HsDo DoExpr tc_stmts io_ids
217 (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc,
220 combine stmt (ids, stmts) = (ids, stmt:stmts)
223 %************************************************************************
225 \subsection{Typechecking an expression}
227 %************************************************************************
230 typecheckExpr :: DynFlags
231 -> PersistentCompilerState
233 -> TypeEnv -- The interactive context's type envt
234 -> PrintUnqualified -- For error printing
236 -> (RenamedHsExpr, -- The expression itself
237 [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files
238 -> IO (Maybe (PersistentCompilerState,
240 [Id], -- always empty (matches typecheckStmt)
243 typecheckExpr dflags pcs hst ic_type_env unqual this_mod (expr, decls)
244 = typecheck dflags pcs hst unqual $
246 -- use the default default settings, i.e. [Integer, Double]
247 tcSetDefaultTys defaultDefaultTys $
249 -- Typecheck the extra declarations
250 tcExtraDecls pcs hst this_mod decls `thenTc` \ (new_pcs, env) ->
252 -- Now typecheck the expression
254 tcExtendGlobalTypeEnv ic_type_env $
256 newTyVarTy openTypeKind `thenTc` \ ty ->
257 tcMonoExpr expr ty `thenTc` \ (e', lie) ->
258 tcSimplifyInfer smpl_doc (tyVarsOfType ty) lie
259 `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) ->
260 tcSimplifyTop lie_free `thenTc` \ const_binds ->
262 let all_expr = mkHsLet const_binds $
268 all_expr_ty = mkForAllTys qtvs $
269 mkFunTys (map idType dict_ids) $
273 zonkExpr all_expr `thenNF_Tc` \ zonked_expr ->
274 zonkTcType all_expr_ty `thenNF_Tc` \ zonked_ty ->
275 ioToTc (dumpIfSet_dyn dflags
276 Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_`
277 returnTc (new_pcs, zonked_expr, [], zonked_ty)
280 smpl_doc = ptext SLIT("main expression")
283 %************************************************************************
285 \subsection{Typechecking extra declarations}
287 %************************************************************************
292 -> PersistentCompilerState
294 -> PrintUnqualified -- For error printing
295 -> Module -- Is this really needed
296 -> [RenamedHsDecl] -- extra decls sucked in from interface files
297 -> IO (Maybe PersistentCompilerState)
299 typecheckExtraDecls dflags pcs hst unqual this_mod decls
300 = typecheck dflags pcs hst unqual $
301 tcExtraDecls pcs hst this_mod decls `thenTc` \ (new_pcs, _) ->
304 tcExtraDecls :: PersistentCompilerState
308 -> TcM (PersistentCompilerState, TcEnv)
309 -- Returned environment includes instances
311 tcExtraDecls pcs hst this_mod decls
312 = tcIfaceImports this_mod decls `thenTc` \ (env, all_things, dfuns, rules) ->
313 addInstDFuns (pcs_insts pcs) dfuns `thenNF_Tc` \ new_pcs_insts ->
315 new_pcs_pte = extendTypeEnvList (pcs_PTE pcs) all_things
316 new_pcs_rules = addIfaceRules (pcs_rules pcs) rules
318 new_pcs :: PersistentCompilerState
319 new_pcs = pcs { pcs_PTE = new_pcs_pte,
320 pcs_insts = new_pcs_insts,
321 pcs_rules = new_pcs_rules
324 -- Initialise the instance environment
326 initInstEnv new_pcs hst `thenNF_Tc` \ inst_env ->
327 tcSetInstEnv inst_env tcGetEnv
328 ) `thenNF_Tc` \ new_env ->
329 returnTc (new_pcs, new_env)
333 %************************************************************************
335 \subsection{Typechecking a module}
337 %************************************************************************
342 -> PersistentCompilerState
344 -> PrintUnqualified -- For error printing
346 -> IO (Maybe (PersistentCompilerState, TcResults))
347 -- The new PCS is Augmented with imported information,
348 -- (but not stuff from this module)
352 -- All these fields have info *just for this module*
353 tc_env :: TypeEnv, -- The top level TypeEnv
354 tc_insts :: [DFunId], -- Instances
355 tc_rules :: [TypecheckedRuleDecl], -- Transformation rules
356 tc_binds :: TypecheckedMonoBinds, -- Bindings
357 tc_fords :: [TypecheckedForeignDecl] -- Foreign import & exports.
361 typecheckModule dflags pcs hst unqual rn_result
362 = do { maybe_tc_result <- typecheck dflags pcs hst unqual $
363 tcModule pcs hst rn_result
364 ; printTcDump dflags unqual maybe_tc_result
365 ; return maybe_tc_result }
367 tcModule :: PersistentCompilerState
370 -> TcM (PersistentCompilerState, TcResults)
372 tcModule pcs hst (RnResult { rr_decls = decls, rr_mod = this_mod,
373 rr_fixities = fix_env, rr_main = maybe_main_name })
374 = fixTc (\ ~(unf_env, _, _) ->
375 -- Loop back the final environment, including the fully zonked
376 -- versions of bindings from this module. In the presence of mutual
377 -- recursion, interface type signatures may mention variables defined
378 -- in this module, which is why the knot is so big
380 -- Type-check the type and class decls, and all imported decls
381 tcImports unf_env pcs hst this_mod
382 tycl_decls iface_inst_decls iface_rule_decls `thenTc` \ (env1, new_pcs) ->
386 -- Do the source-language instances, including derivings
387 initInstEnv new_pcs hst `thenNF_Tc` \ inst_env1 ->
388 tcInstDecls1 (pcs_PRS new_pcs) inst_env1
390 tycl_decls src_inst_decls `thenTc` \ (inst_env2, inst_info, deriv_binds) ->
391 tcSetInstEnv inst_env2 $
393 -- Foreign import declarations next
394 traceTc (text "Tc4") `thenNF_Tc_`
395 tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) ->
396 tcExtendGlobalValEnv fo_ids $
398 -- Default declarations
399 tcDefaults decls `thenTc` \ defaulting_tys ->
400 tcSetDefaultTys defaulting_tys $
402 -- Value declarations next.
403 -- We also typecheck any extra binds that came out of the "deriving" process
404 traceTc (text "Default types" <+> ppr defaulting_tys) `thenNF_Tc_`
405 traceTc (text "Tc5") `thenNF_Tc_`
406 tcTopBinds (val_binds `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env2), lie_valdecls) ->
408 -- Second pass over class and instance declarations,
409 -- plus rules and foreign exports, to generate bindings
411 traceTc (text "Tc6") `thenNF_Tc_`
412 traceTc (ppr (getTcGEnv env2)) `thenNF_Tc_`
413 tcClassDecls2 this_mod tycl_decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds, dm_ids) ->
414 tcExtendGlobalValEnv dm_ids $
415 traceTc (text "Tc7") `thenNF_Tc_`
416 tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
417 traceTc (text "Tc8") `thenNF_Tc_`
418 tcForeignExports this_mod decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) ->
419 traceTc (text "Tc9") `thenNF_Tc_`
420 tcSourceRules src_rule_decls `thenNF_Tc` \ (lie_rules, src_rules) ->
422 -- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED
423 traceTc (text "Tc10") `thenNF_Tc_`
424 tcCheckMain maybe_main_name `thenTc` \ (main_bind, lie_main) ->
426 -- Deal with constant or ambiguous InstIds. How could
427 -- there be ambiguous ones? They can only arise if a
428 -- top-level decl falls under the monomorphism
429 -- restriction, and no subsequent decl instantiates its
430 -- type. (Usually, ambiguous type variables are resolved
431 -- during the generalisation step.)
433 -- Note that we must do this *after* tcCheckMain, because of the
434 -- following bizarre case:
436 -- Here, we infer main :: forall a. m a, where m is a free
437 -- type variable. tcCheckMain will unify it with IO, and that
438 -- must happen before tcSimplifyTop, since the latter will report
441 lie_alldecls = lie_valdecls `plusLIE`
442 lie_instdecls `plusLIE`
443 lie_clasdecls `plusLIE`
444 lie_fodecls `plusLIE`
448 tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds ->
449 traceTc (text "endsimpltop") `thenTc_`
452 -- Backsubstitution. This must be done last.
453 -- Even tcSimplifyTop may do some unification.
455 all_binds = val_binds `AndMonoBinds`
456 inst_binds `AndMonoBinds`
457 cls_dm_binds `AndMonoBinds`
458 const_inst_binds `AndMonoBinds`
459 foe_binds `AndMonoBinds`
462 traceTc (text "Tc7") `thenNF_Tc_`
463 zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', final_env) ->
465 -- zonkTopBinds puts all the top-level Ids into the tcGEnv
466 traceTc (text "Tc8") `thenNF_Tc_`
467 zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' ->
468 traceTc (text "Tc9") `thenNF_Tc_`
469 zonkRules src_rules `thenNF_Tc` \ src_rules' ->
472 let src_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv final_env))
473 -- This is horribly crude; the env might be jolly big
475 traceTc (text "Tc10") `thenNF_Tc_`
478 TcResults { tc_env = mkTypeEnv src_things,
479 tc_insts = map iDFunId inst_info,
480 tc_binds = all_binds',
481 tc_fords = foi_decls ++ foe_decls',
482 tc_rules = src_rules'
485 ) `thenTc` \ (_, pcs, tc_result) ->
486 returnTc (pcs, tc_result)
488 tycl_decls = [d | TyClD d <- decls]
489 rule_decls = [d | RuleD d <- decls]
490 inst_decls = [d | InstD d <- decls]
491 val_decls = [d | ValD d <- decls]
493 core_binds = [d | d <- tycl_decls, isCoreDecl d]
495 (src_inst_decls, iface_inst_decls) = partition isSourceInstDecl inst_decls
496 (src_rule_decls, iface_rule_decls) = partition (isSourceRuleDecl this_mod) rule_decls
497 val_binds = foldr ThenBinds EmptyBinds val_decls
501 %************************************************************************
503 \subsection{Typechecking interface decls}
505 %************************************************************************
510 -> PersistentCompilerState
512 -> ModIface -- Iface for this module (just module & fixities)
514 -> IO (Maybe (PersistentCompilerState, ModDetails))
515 -- The new PCS is Augmented with imported information,
516 -- (but not stuff from this module).
518 typecheckIface dflags pcs hst mod_iface decls
519 = do { maybe_tc_stuff <- typecheck dflags pcs hst alwaysQualify $
520 tcIface pcs this_mod decls
521 ; printIfaceDump dflags maybe_tc_stuff
522 ; return maybe_tc_stuff }
524 this_mod = mi_module mod_iface
526 tcIface pcs this_mod decls
527 -- The decls are coming from this_mod's interface file, together
528 -- with imported interface decls that belong in the "package" stuff.
529 -- (With GHCi, all the home modules have already been processed.)
530 -- That is why we need to do the partitioning below.
531 = tcIfaceImports this_mod decls `thenTc` \ (_, all_things, dfuns, rules) ->
534 -- Do the partitioning (see notes above)
535 (local_things, imported_things) = partition (isLocalThing this_mod) all_things
536 (local_rules, imported_rules) = partition is_local_rule rules
537 (local_dfuns, imported_dfuns) = partition (isLocalThing this_mod) dfuns
538 is_local_rule (IfaceRuleOut n _) = isLocalThing this_mod n
540 addInstDFuns (pcs_insts pcs) imported_dfuns `thenNF_Tc` \ new_pcs_insts ->
542 new_pcs_pte :: PackageTypeEnv
543 new_pcs_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
544 new_pcs_rules = addIfaceRules (pcs_rules pcs) imported_rules
546 new_pcs :: PersistentCompilerState
547 new_pcs = pcs { pcs_PTE = new_pcs_pte,
548 pcs_insts = new_pcs_insts,
549 pcs_rules = new_pcs_rules
552 mod_details = ModDetails { md_types = mkTypeEnv local_things,
553 md_insts = local_dfuns,
554 md_rules = [(id,rule) | IfaceRuleOut id rule <- local_rules],
556 -- All the rules from an interface are of the IfaceRuleOut form
558 returnTc (new_pcs, mod_details)
561 tcIfaceImports :: Module
562 -> [RenamedHsDecl] -- All interface-file decls
563 -> TcM (TcEnv, [TyThing], [DFunId], [TypecheckedRuleDecl])
564 tcIfaceImports this_mod decls
565 -- The decls are all interface-file declarations
567 inst_decls = [d | InstD d <- decls]
568 tycl_decls = [d | TyClD d <- decls]
569 rule_decls = [d | RuleD d <- decls]
571 fixTc (\ ~(unf_env, _, _, _) ->
572 -- This fixTc follows the same general plan as tcImports,
573 -- which is better commented (below)
574 tcTyAndClassDecls this_mod tycl_decls `thenTc` \ tycl_things ->
575 tcExtendGlobalEnv tycl_things $
576 tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
577 tcExtendGlobalValEnv sig_ids $
578 tcIfaceInstDecls1 inst_decls `thenTc` \ dfuns ->
579 tcIfaceRules rule_decls `thenTc` \ rules ->
580 tcGetEnv `thenTc` \ env ->
582 all_things = map AnId sig_ids ++ tycl_things
584 returnTc (env, all_things, dfuns, rules)
588 tcImports :: RecTcEnv
589 -> PersistentCompilerState
595 -> TcM (TcEnv, PersistentCompilerState)
597 -- tcImports is a slight mis-nomer.
598 -- It deals with everything that could be an import:
599 -- type and class decls (some source, some imported)
600 -- interface signatures (checked lazily)
601 -- instance decls (some source, some imported)
602 -- rule decls (all imported)
603 -- These can occur in source code too, of course
605 -- tcImports is only called when processing source code,
606 -- so that any interface-file declarations are for other modules, not this one
608 tcImports unf_env pcs hst this_mod
609 tycl_decls inst_decls rule_decls
610 -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
611 -- which is done lazily [ie failure just drops the pragma
612 -- without having any global-failure effect].
614 -- unf_env is also used to get the pragama info
615 -- for imported dfuns and default methods
618 -- tcImports recovers internally, but if anything gave rise to
619 -- an error we'd better stop now, to avoid a cascade
621 traceTc (text "Tc1") `thenNF_Tc_`
622 tcTyAndClassDecls this_mod tycl_decls `thenTc` \ tycl_things ->
623 tcExtendGlobalEnv tycl_things $
625 -- Interface type signatures
626 -- We tie a knot so that the Ids read out of interfaces are in scope
627 -- when we read their pragmas.
628 -- What we rely on is that pragmas are typechecked lazily; if
629 -- any type errors are found (ie there's an inconsistency)
630 -- we silently discard the pragma
631 traceTc (text "Tc2") `thenNF_Tc_`
632 tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
633 tcExtendGlobalValEnv sig_ids $
635 -- Typecheck the instance decls, includes deriving
636 -- Note that imported dictionary functions are already
637 -- in scope from the preceding tcInterfaceSigs
638 traceTc (text "Tc3") `thenNF_Tc_`
639 tcIfaceInstDecls1 inst_decls `thenTc` \ dfuns ->
640 tcIfaceRules rule_decls `thenNF_Tc` \ rules ->
642 addInstDFuns (pcs_insts pcs) dfuns `thenNF_Tc` \ new_pcs_insts ->
643 tcGetEnv `thenTc` \ unf_env ->
645 -- sometimes we're compiling in the context of a package module
646 -- (on the GHCi command line, for example). In this case, we
647 -- want to treat everything we pulled in as an imported thing.
648 imported_things = map AnId sig_ids ++ -- All imported
649 filter (not . isLocalThing this_mod) tycl_things
651 new_pte :: PackageTypeEnv
652 new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
654 new_pcs_rules = addIfaceRules (pcs_rules pcs) rules
656 new_pcs :: PersistentCompilerState
657 new_pcs = pcs { pcs_PTE = new_pte,
658 pcs_insts = new_pcs_insts,
659 pcs_rules = new_pcs_rules
662 returnTc (unf_env, new_pcs)
664 isSourceRuleDecl :: Module -> RenamedRuleDecl -> Bool
665 -- This is a bit gruesome.
666 -- Usually, HsRules come only from source files; IfaceRules only from interface files
667 -- But built-in rules appear as an IfaceRuleOut... and when compiling
668 -- the source file for that built-in rule, we want to treat it as a source
669 -- rule, so it gets put with the other rules for that module.
670 isSourceRuleDecl this_mod (HsRule _ _ _ _ _ _) = True
671 isSourceRuleDecl this_mod (IfaceRule _ _ _ n _ _ _) = False
672 isSourceRuleDecl this_mod (IfaceRuleOut name _) = isLocalThing this_mod name
674 addIfaceRules rule_base rules
675 = foldl add_rule rule_base rules
677 add_rule rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule)
683 -> PersistentCompilerState
685 -> ModIface -- Iface for this module (just module & fixities)
687 -> IO (Maybe (PersistentCompilerState, (TypeEnv, [TypecheckedCoreBind], [TypecheckedRuleDecl])))
688 typecheckCoreModule dflags pcs hst mod_iface decls
689 = do { maybe_tc_stuff <- typecheck dflags pcs hst alwaysQualify $
690 tcCoreDecls this_mod decls
692 -- ; printIfaceDump dflags maybe_tc_stuff
694 -- Q: Is it OK not to extend PCS here?
695 -- (in the event that it needs to be, I'm returning the PCS passed in.)
696 ; case maybe_tc_stuff of
697 Nothing -> return Nothing
698 Just result -> return (Just (pcs, result)) }
700 this_mod = mi_module mod_iface
701 core_decls = [d | (TyClD d) <- decls, isCoreDecl d]
704 tcCoreDecls :: Module
705 -> [RenamedHsDecl] -- All interface-file decls
706 -> TcM (TypeEnv, [TypecheckedCoreBind], [TypecheckedRuleDecl])
707 tcCoreDecls this_mod decls
708 -- The decls are all TyClD declarations coming from External Core input.
710 tycl_decls = [d | TyClD d <- decls]
711 rule_decls = [d | RuleD d <- decls]
712 core_decls = filter isCoreDecl tycl_decls
714 fixTc (\ ~(unf_env, _) ->
715 -- This fixTc follows the same general plan as tcImports,
716 -- which is better commented.
717 -- [ Q: do we need to tie a knot for External Core? ]
718 tcTyAndClassDecls this_mod tycl_decls `thenTc` \ tycl_things ->
719 tcExtendGlobalEnv tycl_things $
721 tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
722 tcExtendGlobalValEnv sig_ids $
724 tcCoreBinds core_decls `thenTc` \ core_prs ->
726 local_ids = map fst core_prs
728 tcExtendGlobalValEnv local_ids $
730 tcIfaceRules rule_decls `thenTc` \ rules ->
733 src_things = filter (isLocalThing this_mod) tycl_things
734 ++ map AnId local_ids
736 tcGetEnv `thenNF_Tc` \ env ->
737 returnTc (env, (mkTypeEnv src_things, core_prs, rules))
738 ) `thenTc` \ (_, result) ->
743 %************************************************************************
745 \subsection{Checking the type of main}
747 %************************************************************************
749 We must check that in module Main,
750 a) Main.main is in scope
751 b) Main.main :: forall a1...an. IO t, for some type t
754 $main = GHC.TopHandler.runIO Main.main
757 GHC.TopHandler.runIO :: IO a -> IO a
758 catches the top level exceptions.
759 It accepts a Main.main of any type (IO a).
762 tcCheckMain :: Maybe Name -> TcM (TypecheckedMonoBinds, LIE)
763 tcCheckMain Nothing = returnTc (EmptyMonoBinds, emptyLIE)
765 tcCheckMain (Just main_name)
766 = tcLookupId main_name `thenNF_Tc` \ main_id ->
767 -- If it is not Nothing, it should be in the env
768 tcAddSrcLoc (getSrcLoc main_id) $
769 tcAddErrCtxt mainCtxt $
770 newTyVarTy liftedTypeKind `thenNF_Tc` \ ty ->
771 tcMonoExpr rhs ty `thenTc` \ (main_expr, lie) ->
772 zonkTcType ty `thenNF_Tc` \ ty ->
775 dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty)
777 returnTc (VarMonoBind dollar_main_id main_expr, lie)
779 rhs = HsApp (HsVar runIOName) (HsVar main_name)
781 is_io :: Type -> Bool -- True for IO a
782 is_io tau = case tcSplitTyConApp_maybe tau of
783 Just (tc, [_]) -> getName tc == ioTyConName
786 mainCtxt = ptext SLIT("When checking the type of 'main'")
790 %************************************************************************
792 \subsection{Interfacing the Tc monad to the IO monad}
794 %************************************************************************
797 typecheck :: DynFlags
798 -> PersistentCompilerState
800 -> PrintUnqualified -- For error printing
804 typecheck dflags pcs hst unqual thing_inside
805 = do { showPass dflags "Typechecker";
806 ; env <- initTcEnv hst (pcs_PTE pcs)
808 ; (maybe_tc_result, errs) <- initTc dflags env thing_inside
810 ; printErrorsAndWarnings unqual errs
812 ; if errorsFound errs then
815 return maybe_tc_result
820 %************************************************************************
822 \subsection{Dumping output}
824 %************************************************************************
827 printTcDump dflags unqual Nothing = return ()
828 printTcDump dflags unqual (Just (_, results))
829 = do if dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags then
830 printForUser stdout unqual (dump_tc_iface dflags results)
833 dumpIfSet_dyn dflags Opt_D_dump_tc
834 -- foreign x-d's have undefined's in their types; hence can't show the tc_fords
835 "Typechecked" (ppr (tc_binds results) {- $$ ppr (tc_fords results)-})
838 printIfaceDump dflags Nothing = return ()
839 printIfaceDump dflags (Just (_, details))
840 = dumpIfSet_dyn_or dflags [Opt_D_dump_types, Opt_D_dump_tc]
841 "Interface" (pprModDetails details)
843 dump_tc_iface dflags results
844 = vcat [pprModDetails (ModDetails {md_types = tc_env results,
845 md_insts = tc_insts results,
846 md_rules = [], md_binds = []}) ,
847 ppr_rules (tc_rules results),
849 if dopt Opt_Generics dflags then
850 ppr_gen_tycons (typeEnvTyCons (tc_env results))
856 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
857 nest 4 (vcat (map ppr rs)),
860 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
861 vcat (map ppr_gen_tycon tcs),
865 -- x&y are now Id's, not CoreExpr's
867 | Just ep <- tyConGenInfo tycon
868 = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
870 | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
873 = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
874 ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
875 ptext SLIT("To:") <+> ppr (unfoldingTemplate (idUnfolding to))
878 (_,from_tau) = tcSplitForAllTys (idType from)