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, runMainName,
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,
31 zonkExpr, zonkIdBndr, zonkCoreBinds
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 = tcLookupGlobalId returnIOName `thenNF_Tc` \ return_id ->
179 tcLookupGlobalId bindIOName `thenNF_Tc` \ bind_id ->
180 tcLookupGlobalId failIOName `thenNF_Tc` \ fail_id ->
181 tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon ->
182 newTyVarTy liftedTypeKind `thenNF_Tc` \ res_ty ->
184 io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty)
186 -- mk_return builds the expression
187 -- returnIO @ [()] [coerce () x, .., coerce () z]
188 mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy])
189 (ExplicitList unitTy (map mk_item ids))
191 mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy])
195 traceTc (text "tcs 2") `thenNF_Tc_`
196 tcStmtsAndThen combine (DoCtxt DoExpr) io_ty stmts (
197 -- Look up the names right in the middle,
198 -- where they will all be in scope
199 mapNF_Tc tcLookupId names `thenNF_Tc` \ ids ->
200 returnTc ((ids, [ResultStmt (mk_return ids) noSrcLoc]), emptyLIE)
201 ) `thenTc` \ ((ids, tc_stmts), lie) ->
203 -- Simplify the context right here, so that we fail
204 -- if there aren't enough instances. Notably, when we see
206 -- we use tryTc_ to try it <- e
207 -- and then let it = e
208 -- It's the simplify step that rejects the first.
210 traceTc (text "tcs 3") `thenNF_Tc_`
211 tcSimplifyTop lie `thenTc` \ const_binds ->
212 traceTc (text "tcs 4") `thenNF_Tc_`
214 returnTc (mkHsLet const_binds $
215 HsDoOut DoExpr tc_stmts return_id bind_id fail_id
216 (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc,
219 combine stmt (ids, stmts) = (ids, stmt:stmts)
222 %************************************************************************
224 \subsection{Typechecking an expression}
226 %************************************************************************
229 typecheckExpr :: DynFlags
230 -> PersistentCompilerState
232 -> TypeEnv -- The interactive context's type envt
233 -> PrintUnqualified -- For error printing
235 -> (RenamedHsExpr, -- The expression itself
236 [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files
237 -> IO (Maybe (PersistentCompilerState,
239 [Id], -- always empty (matches typecheckStmt)
242 typecheckExpr dflags pcs hst ic_type_env unqual this_mod (expr, decls)
243 = typecheck dflags pcs hst unqual $
245 -- use the default default settings, i.e. [Integer, Double]
246 tcSetDefaultTys defaultDefaultTys $
248 -- Typecheck the extra declarations
249 tcExtraDecls pcs hst this_mod decls `thenTc` \ (new_pcs, env) ->
251 -- Now typecheck the expression
253 tcExtendGlobalTypeEnv ic_type_env $
255 newTyVarTy openTypeKind `thenTc` \ ty ->
256 tcMonoExpr expr ty `thenTc` \ (e', lie) ->
257 tcSimplifyInfer smpl_doc (tyVarsOfType ty) lie
258 `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) ->
259 tcSimplifyTop lie_free `thenTc` \ const_binds ->
261 let all_expr = mkHsLet const_binds $
267 all_expr_ty = mkForAllTys qtvs $
268 mkFunTys (map idType dict_ids) $
272 zonkExpr all_expr `thenNF_Tc` \ zonked_expr ->
273 zonkTcType all_expr_ty `thenNF_Tc` \ zonked_ty ->
274 ioToTc (dumpIfSet_dyn dflags
275 Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_`
276 returnTc (new_pcs, zonked_expr, [], zonked_ty)
279 smpl_doc = ptext SLIT("main expression")
282 %************************************************************************
284 \subsection{Typechecking extra declarations}
286 %************************************************************************
291 -> PersistentCompilerState
293 -> PrintUnqualified -- For error printing
294 -> Module -- Is this really needed
295 -> [RenamedHsDecl] -- extra decls sucked in from interface files
296 -> IO (Maybe PersistentCompilerState)
298 typecheckExtraDecls dflags pcs hst unqual this_mod decls
299 = typecheck dflags pcs hst unqual $
300 tcExtraDecls pcs hst this_mod decls `thenTc` \ (new_pcs, _) ->
303 tcExtraDecls :: PersistentCompilerState
307 -> TcM (PersistentCompilerState, TcEnv)
308 -- Returned environment includes instances
310 tcExtraDecls pcs hst this_mod decls
311 = tcIfaceImports this_mod decls `thenTc` \ (env, all_things, dfuns, rules) ->
312 addInstDFuns (pcs_insts pcs) dfuns `thenNF_Tc` \ new_pcs_insts ->
314 new_pcs_pte = extendTypeEnvList (pcs_PTE pcs) all_things
315 new_pcs_rules = addIfaceRules (pcs_rules pcs) rules
317 new_pcs :: PersistentCompilerState
318 new_pcs = pcs { pcs_PTE = new_pcs_pte,
319 pcs_insts = new_pcs_insts,
320 pcs_rules = new_pcs_rules
323 -- Initialise the instance environment
325 initInstEnv new_pcs hst `thenNF_Tc` \ inst_env ->
326 tcSetInstEnv inst_env tcGetEnv
327 ) `thenNF_Tc` \ new_env ->
328 returnTc (new_pcs, new_env)
332 %************************************************************************
334 \subsection{Typechecking a module}
336 %************************************************************************
341 -> PersistentCompilerState
343 -> PrintUnqualified -- For error printing
345 -> IO (Maybe (PersistentCompilerState, TcResults))
346 -- The new PCS is Augmented with imported information,
347 -- (but not stuff from this module)
351 -- All these fields have info *just for this module*
352 tc_env :: TypeEnv, -- The top level TypeEnv
353 tc_insts :: [DFunId], -- Instances
354 tc_rules :: [TypecheckedRuleDecl], -- Transformation rules
355 tc_binds :: TypecheckedMonoBinds, -- Bindings
356 tc_fords :: [TypecheckedForeignDecl] -- Foreign import & exports.
360 typecheckModule dflags pcs hst unqual rn_result
361 = do { maybe_tc_result <- typecheck dflags pcs hst unqual $
362 tcModule pcs hst rn_result
363 ; printTcDump dflags unqual maybe_tc_result
364 ; return maybe_tc_result }
366 tcModule :: PersistentCompilerState
369 -> TcM (PersistentCompilerState, TcResults)
371 tcModule pcs hst (RnResult { rr_decls = decls, rr_mod = this_mod,
372 rr_fixities = fix_env, rr_main = maybe_main_name })
373 = fixTc (\ ~(unf_env, _, _) ->
374 -- Loop back the final environment, including the fully zonked
375 -- versions of bindings from this module. In the presence of mutual
376 -- recursion, interface type signatures may mention variables defined
377 -- in this module, which is why the knot is so big
379 -- Type-check the type and class decls, and all imported decls
380 tcImports unf_env pcs hst this_mod
381 tycl_decls iface_inst_decls iface_rule_decls `thenTc` \ (env1, new_pcs) ->
385 -- Do the source-language instances, including derivings
386 initInstEnv new_pcs hst `thenNF_Tc` \ inst_env1 ->
387 tcInstDecls1 (pcs_PRS new_pcs) inst_env1
389 tycl_decls src_inst_decls `thenTc` \ (inst_env2, inst_info, deriv_binds) ->
390 tcSetInstEnv inst_env2 $
392 -- Foreign import declarations next
393 traceTc (text "Tc4") `thenNF_Tc_`
394 tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) ->
395 tcExtendGlobalValEnv fo_ids $
397 -- Default declarations
398 tcDefaults decls `thenTc` \ defaulting_tys ->
399 tcSetDefaultTys defaulting_tys $
401 -- Value declarations next.
402 -- We also typecheck any extra binds that came out of the "deriving" process
403 traceTc (text "Default types" <+> ppr defaulting_tys) `thenNF_Tc_`
404 traceTc (text "Tc5") `thenNF_Tc_`
405 tcTopBinds (val_binds `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env2), lie_valdecls) ->
407 -- Second pass over class and instance declarations,
408 -- plus rules and foreign exports, to generate bindings
410 traceTc (text "Tc6") `thenNF_Tc_`
411 traceTc (ppr (getTcGEnv env2)) `thenNF_Tc_`
412 tcClassDecls2 this_mod tycl_decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds, dm_ids) ->
413 tcExtendGlobalValEnv dm_ids $
414 traceTc (text "Tc7") `thenNF_Tc_`
415 tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
416 traceTc (text "Tc8") `thenNF_Tc_`
417 tcForeignExports this_mod decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) ->
418 traceTc (text "Tc9") `thenNF_Tc_`
419 tcSourceRules src_rule_decls `thenNF_Tc` \ (lie_rules, src_rules) ->
421 -- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED
422 traceTc (text "Tc10") `thenNF_Tc_`
423 tcCheckMain maybe_main_name `thenTc` \ (main_bind, lie_main) ->
425 -- Deal with constant or ambiguous InstIds. How could
426 -- there be ambiguous ones? They can only arise if a
427 -- top-level decl falls under the monomorphism
428 -- restriction, and no subsequent decl instantiates its
429 -- type. (Usually, ambiguous type variables are resolved
430 -- during the generalisation step.)
432 -- Note that we must do this *after* tcCheckMain, because of the
433 -- following bizarre case:
435 -- Here, we infer main :: forall a. m a, where m is a free
436 -- type variable. tcCheckMain will unify it with IO, and that
437 -- must happen before tcSimplifyTop, since the latter will report
440 lie_alldecls = lie_valdecls `plusLIE`
441 lie_instdecls `plusLIE`
442 lie_clasdecls `plusLIE`
443 lie_fodecls `plusLIE`
447 tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds ->
448 traceTc (text "endsimpltop") `thenTc_`
450 -- Backsubstitution. This must be done last.
451 -- Even tcSimplifyTop may do some unification.
453 all_binds = val_binds `AndMonoBinds`
454 inst_binds `AndMonoBinds`
455 cls_dm_binds `AndMonoBinds`
456 const_inst_binds `AndMonoBinds`
457 foe_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 core_binds = [d | d <- tycl_decls, isCoreDecl d]
493 (src_inst_decls, iface_inst_decls) = partition isSourceInstDecl inst_decls
494 (src_rule_decls, iface_rule_decls) = partition (isSourceRuleDecl this_mod) rule_decls
495 val_binds = foldr ThenBinds EmptyBinds val_decls
499 %************************************************************************
501 \subsection{Typechecking interface decls}
503 %************************************************************************
508 -> PersistentCompilerState
510 -> ModIface -- Iface for this module (just module & fixities)
512 -> IO (Maybe (PersistentCompilerState, ModDetails))
513 -- The new PCS is Augmented with imported information,
514 -- (but not stuff from this module).
516 typecheckIface dflags pcs hst mod_iface decls
517 = do { maybe_tc_stuff <- typecheck dflags pcs hst alwaysQualify $
518 tcIface pcs this_mod decls
519 ; printIfaceDump dflags maybe_tc_stuff
520 ; return maybe_tc_stuff }
522 this_mod = mi_module mod_iface
524 tcIface pcs this_mod decls
525 -- The decls are coming from this_mod's interface file, together
526 -- with imported interface decls that belong in the "package" stuff.
527 -- (With GHCi, all the home modules have already been processed.)
528 -- That is why we need to do the partitioning below.
529 = tcIfaceImports this_mod decls `thenTc` \ (_, all_things, dfuns, rules) ->
532 -- Do the partitioning (see notes above)
533 (local_things, imported_things) = partition (isLocalThing this_mod) all_things
534 (local_rules, imported_rules) = partition is_local_rule rules
535 (local_dfuns, imported_dfuns) = partition (isLocalThing this_mod) dfuns
536 is_local_rule (IfaceRuleOut n _) = isLocalThing this_mod n
538 addInstDFuns (pcs_insts pcs) imported_dfuns `thenNF_Tc` \ new_pcs_insts ->
540 new_pcs_pte :: PackageTypeEnv
541 new_pcs_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
542 new_pcs_rules = addIfaceRules (pcs_rules pcs) imported_rules
544 new_pcs :: PersistentCompilerState
545 new_pcs = pcs { pcs_PTE = new_pcs_pte,
546 pcs_insts = new_pcs_insts,
547 pcs_rules = new_pcs_rules
550 mod_details = ModDetails { md_types = mkTypeEnv local_things,
551 md_insts = local_dfuns,
552 md_rules = [(id,rule) | IfaceRuleOut id rule <- local_rules],
554 -- All the rules from an interface are of the IfaceRuleOut form
556 returnTc (new_pcs, mod_details)
559 tcIfaceImports :: Module
560 -> [RenamedHsDecl] -- All interface-file decls
561 -> TcM (TcEnv, [TyThing], [DFunId], [TypecheckedRuleDecl])
562 tcIfaceImports this_mod decls
563 -- The decls are all interface-file declarations
565 inst_decls = [d | InstD d <- decls]
566 tycl_decls = [d | TyClD d <- decls]
567 rule_decls = [d | RuleD d <- decls]
569 fixTc (\ ~(unf_env, _, _, _) ->
570 -- This fixTc follows the same general plan as tcImports,
571 -- which is better commented (below)
572 tcTyAndClassDecls unf_env this_mod tycl_decls `thenTc` \ tycl_things ->
573 tcExtendGlobalEnv tycl_things $
574 tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
575 tcExtendGlobalValEnv sig_ids $
576 tcIfaceInstDecls1 inst_decls `thenTc` \ dfuns ->
577 tcIfaceRules rule_decls `thenTc` \ rules ->
578 tcGetEnv `thenTc` \ env ->
580 all_things = map AnId sig_ids ++ tycl_things
582 returnTc (env, all_things, dfuns, rules)
586 tcImports :: RecTcEnv
587 -> PersistentCompilerState
593 -> TcM (TcEnv, PersistentCompilerState)
595 -- tcImports is a slight mis-nomer.
596 -- It deals with everything that could be an import:
597 -- type and class decls (some source, some imported)
598 -- interface signatures (checked lazily)
599 -- instance decls (some source, some imported)
600 -- rule decls (all imported)
601 -- These can occur in source code too, of course
603 -- tcImports is only called when processing source code,
604 -- so that any interface-file declarations are for other modules, not this one
606 tcImports unf_env pcs hst this_mod
607 tycl_decls inst_decls rule_decls
608 -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
609 -- which is done lazily [ie failure just drops the pragma
610 -- without having any global-failure effect].
612 -- unf_env is also used to get the pragama info
613 -- for imported dfuns and default methods
616 -- tcImports recovers internally, but if anything gave rise to
617 -- an error we'd better stop now, to avoid a cascade
619 traceTc (text "Tc1") `thenNF_Tc_`
620 tcTyAndClassDecls unf_env this_mod tycl_decls `thenTc` \ tycl_things ->
621 tcExtendGlobalEnv tycl_things $
623 -- Interface type signatures
624 -- We tie a knot so that the Ids read out of interfaces are in scope
625 -- when we read their pragmas.
626 -- What we rely on is that pragmas are typechecked lazily; if
627 -- any type errors are found (ie there's an inconsistency)
628 -- we silently discard the pragma
629 traceTc (text "Tc2") `thenNF_Tc_`
630 tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
631 tcExtendGlobalValEnv sig_ids $
633 -- Typecheck the instance decls, includes deriving
634 -- Note that imported dictionary functions are already
635 -- in scope from the preceding tcInterfaceSigs
636 traceTc (text "Tc3") `thenNF_Tc_`
637 tcIfaceInstDecls1 inst_decls `thenTc` \ dfuns ->
638 tcIfaceRules rule_decls `thenNF_Tc` \ rules ->
640 addInstDFuns (pcs_insts pcs) dfuns `thenNF_Tc` \ new_pcs_insts ->
641 tcGetEnv `thenTc` \ unf_env ->
643 -- sometimes we're compiling in the context of a package module
644 -- (on the GHCi command line, for example). In this case, we
645 -- want to treat everything we pulled in as an imported thing.
646 imported_things = map AnId sig_ids ++ -- All imported
647 filter (not . isLocalThing this_mod) tycl_things
649 new_pte :: PackageTypeEnv
650 new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
652 new_pcs_rules = addIfaceRules (pcs_rules pcs) rules
654 new_pcs :: PersistentCompilerState
655 new_pcs = pcs { pcs_PTE = new_pte,
656 pcs_insts = new_pcs_insts,
657 pcs_rules = new_pcs_rules
660 returnTc (unf_env, new_pcs)
662 isSourceRuleDecl :: Module -> RenamedRuleDecl -> Bool
663 -- This is a bit gruesome.
664 -- Usually, HsRules come only from source files; IfaceRules only from interface files
665 -- But built-in rules appear as an IfaceRuleOut... and when compiling
666 -- the source file for that built-in rule, we want to treat it as a source
667 -- rule, so it gets put with the other rules for that module.
668 isSourceRuleDecl this_mod (HsRule _ _ _ _ _ _) = True
669 isSourceRuleDecl this_mod (IfaceRule _ _ _ n _ _ _) = False
670 isSourceRuleDecl this_mod (IfaceRuleOut name _) = isLocalThing this_mod name
672 addIfaceRules rule_base rules
673 = foldl add_rule rule_base rules
675 add_rule rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule)
681 -> PersistentCompilerState
683 -> ModIface -- Iface for this module (just module & fixities)
685 -> IO (Maybe (PersistentCompilerState, TypeEnv, [TypecheckedCoreBind]))
686 typecheckCoreModule dflags pcs hst mod_iface decls
687 = do { maybe_tc_stuff <- typecheck dflags pcs hst alwaysQualify $
688 (tcCoreDecls this_mod decls `thenTc` \ (env,bs) ->
689 zonkCoreBinds bs `thenNF_Tc` \ bs' ->
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 (e,bs) -> return (Just (pcs, e, bs)) }
700 this_mod = mi_module mod_iface
701 core_decls = [d | (TyClD d) <- decls, isCoreDecl d]
703 tcCoreDecls :: Module
704 -> [RenamedHsDecl] -- All interface-file decls
705 -> TcM (TypeEnv, [TypecheckedCoreBind])
706 tcCoreDecls this_mod decls
707 -- The decls are all TyClD declarations coming from External Core input.
709 tycl_decls = [d | TyClD d <- decls]
710 core_decls = filter isCoreDecl tycl_decls
712 fixTc (\ ~(unf_env, _) ->
713 -- This fixTc follows the same general plan as tcImports,
714 -- which is better commented.
715 -- [ Q: do we need to tie a knot for External Core? ]
716 tcTyAndClassDecls unf_env this_mod tycl_decls `thenTc` \ tycl_things ->
717 tcExtendGlobalEnv tycl_things $
718 tcCoreBinds tycl_decls `thenTc` \ core_binds ->
719 tcGetEnv `thenTc` \ env ->
720 returnTc (env, core_binds)
721 ) `thenTc` \ ~(final_env,bs) ->
723 src_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv final_env))
725 returnTc (mkTypeEnv src_things, bs)
730 %************************************************************************
732 \subsection{Checking the type of main}
734 %************************************************************************
736 We must check that in module Main,
737 a) Main.main is in scope
738 b) Main.main :: forall a1...an. IO t, for some type t
741 $main = PrelTopHandler.runMain Main.main
744 PrelTopHandler :: IO a -> IO ()
745 catches the top level exceptions.
746 It accepts a Main.main of any type (IO a).
749 tcCheckMain :: Maybe Name -> TcM (TypecheckedMonoBinds, LIE)
750 tcCheckMain Nothing = returnTc (EmptyMonoBinds, emptyLIE)
752 tcCheckMain (Just main_name)
753 = tcLookupId main_name `thenNF_Tc` \ main_id ->
754 -- If it is not Nothing, it should be in the env
755 tcAddSrcLoc (getSrcLoc main_id) $
756 tcAddErrCtxt mainCtxt $
757 newTyVarTy liftedTypeKind `thenNF_Tc` \ ty ->
758 tcMonoExpr rhs ty `thenTc` \ (main_expr, lie) ->
759 zonkTcType ty `thenNF_Tc` \ ty ->
760 ASSERT( is_io_unit ty )
762 dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty)
764 returnTc (VarMonoBind dollar_main_id main_expr, lie)
766 rhs = HsApp (HsVar runMainName) (HsVar main_name)
768 is_io_unit :: Type -> Bool -- True for IO ()
769 is_io_unit tau = case tcSplitTyConApp_maybe tau of
770 Just (tc, [arg]) -> getName tc == ioTyConName && isUnitTy arg
773 mainCtxt = ptext SLIT("When checking the type of 'main'")
777 %************************************************************************
779 \subsection{Interfacing the Tc monad to the IO monad}
781 %************************************************************************
784 typecheck :: DynFlags
785 -> PersistentCompilerState
787 -> PrintUnqualified -- For error printing
791 typecheck dflags pcs hst unqual thing_inside
792 = do { showPass dflags "Typechecker";
793 ; env <- initTcEnv hst (pcs_PTE pcs)
795 ; (maybe_tc_result, errs) <- initTc dflags env thing_inside
797 ; printErrorsAndWarnings unqual errs
799 ; if errorsFound errs then
802 return maybe_tc_result
807 %************************************************************************
809 \subsection{Dumping output}
811 %************************************************************************
814 printTcDump dflags unqual Nothing = return ()
815 printTcDump dflags unqual (Just (_, results))
816 = do if dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags then
817 printForUser stdout unqual (dump_tc_iface dflags results)
820 dumpIfSet_dyn dflags Opt_D_dump_tc
821 -- foreign x-d's have undefined's in their types; hence can't show the tc_fords
822 "Typechecked" (ppr (tc_binds results) {- $$ ppr (tc_fords results)-})
825 printIfaceDump dflags Nothing = return ()
826 printIfaceDump dflags (Just (_, details))
827 = dumpIfSet_dyn_or dflags [Opt_D_dump_types, Opt_D_dump_tc]
828 "Interface" (pprModDetails details)
830 dump_tc_iface dflags results
831 = vcat [pprModDetails (ModDetails {md_types = tc_env results,
832 md_insts = tc_insts results,
833 md_rules = [], md_binds = []}) ,
834 ppr_rules (tc_rules results),
836 if dopt Opt_Generics dflags then
837 ppr_gen_tycons (typeEnvTyCons (tc_env results))
843 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
844 nest 4 (vcat (map ppr rs)),
847 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
848 vcat (map ppr_gen_tycon tcs),
852 -- x&y are now Id's, not CoreExpr's
854 | Just ep <- tyConGenInfo tycon
855 = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
857 | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
860 = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
861 ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
862 ptext SLIT("To:") <+> ppr (unfoldingTemplate (idUnfolding to))
865 (_,from_tau) = tcSplitForAllTys (idType from)