2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcModule]{Typechecking a whole module}
8 typecheckModule, typecheckIface, typecheckExpr, TcResults(..)
11 #include "HsVersions.h"
13 import CmdLineOpts ( DynFlag(..), DynFlags, opt_PprStyle_Debug )
14 import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
15 isIfaceRuleDecl, nullBinds, andMonoBindList
17 import HsTypes ( toHsType )
18 import PrelNames ( SyntaxMap, mAIN_Name, mainName, ioTyConName, printName )
19 import RnHsSyn ( RenamedHsBinds, RenamedHsDecl, RenamedHsExpr )
20 import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr,
21 TypecheckedForeignDecl, TypecheckedRuleDecl,
22 zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet,
28 import TcType ( newTyVarTy, zonkTcType, tcInstType )
29 import TcUnify ( unifyTauTy )
30 import Inst ( plusLIE )
31 import VarSet ( varSetElems )
32 import TcBinds ( tcTopBinds )
33 import TcClassDcl ( tcClassDecls2 )
34 import TcDefaults ( tcDefaults, defaultDefaultTys )
35 import TcExpr ( tcMonoExpr )
36 import TcEnv ( TcEnv, RecTcEnv, InstInfo, tcExtendGlobalValEnv, tcLookup_maybe,
37 isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv,
38 TcTyThing(..), tcLookupTyCon
40 import TcRules ( tcIfaceRules, tcSourceRules )
41 import TcForeign ( tcForeignImports, tcForeignExports )
42 import TcIfaceSig ( tcInterfaceSigs )
43 import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
44 import TcSimplify ( tcSimplifyTop, tcSimplifyInfer )
45 import TcTyClsDecls ( tcTyAndClassDecls )
47 import CoreUnfold ( unfoldingTemplate, hasUnfolding )
48 import Type ( funResultTy, splitForAllTys, mkForAllTys, mkFunTys,
49 liftedTypeKind, openTypeKind, mkTyConApp, tyVarsOfType, tidyType )
50 import ErrUtils ( printErrorsAndWarnings, errorsFound, dumpIfSet_dyn, showPass )
51 import Id ( idType, idName, isLocalId, idUnfolding )
52 import Module ( Module, isHomeModule, moduleName )
53 import Name ( Name, toRdrName, isGlobalName )
54 import Name ( nameEnvElts, lookupNameEnv )
55 import TyCon ( tyConGenInfo )
57 import BasicTypes ( EP(..), Fixity )
59 import HscTypes ( PersistentCompilerState(..), HomeSymbolTable,
60 PackageTypeEnv, ModIface(..),
61 TypeEnv, extendTypeEnvList,
62 TyThing(..), implicitTyThingIds,
67 Outside-world interface:
70 -- Convenient type synonyms first:
73 -- All these fields have info *just for this module*
74 tc_env :: TypeEnv, -- The top level TypeEnv
75 tc_binds :: TypecheckedMonoBinds, -- Bindings
76 tc_fords :: [TypecheckedForeignDecl], -- Foreign import & exports.
77 tc_rules :: [TypecheckedRuleDecl] -- Transformation rules
83 -> PersistentCompilerState
85 -> ModIface -- Iface for this module (just module & fixities)
86 -> PrintUnqualified -- For error printing
87 -> (SyntaxMap, [RenamedHsDecl])
88 -> IO (Maybe (PersistentCompilerState, TcResults))
89 -- The new PCS is Augmented with imported information,
90 -- (but not stuff from this module)
93 typecheckModule dflags pcs hst mod_iface unqual (syn_map, decls)
94 = do { maybe_tc_result <- typecheck dflags syn_map pcs hst unqual $
95 tcModule pcs hst get_fixity this_mod decls
96 ; printTcDump dflags maybe_tc_result
97 ; return maybe_tc_result }
99 this_mod = mi_module mod_iface
100 fixity_env = mi_fixities mod_iface
102 get_fixity :: Name -> Maybe Fixity
103 get_fixity nm = lookupNameEnv fixity_env nm
108 -> PersistentCompilerState
110 -> ModIface -- Iface for this module (just module & fixities)
111 -> (SyntaxMap, [RenamedHsDecl])
112 -> IO (Maybe (PersistentCompilerState, TypeEnv, [TypecheckedRuleDecl]))
113 -- The new PCS is Augmented with imported information,
114 -- (but not stuff from this module).
115 -- The TcResults returned contains only the environment
119 typecheckIface dflags pcs hst mod_iface (syn_map, decls)
120 = do { maybe_tc_stuff <- typecheck dflags syn_map pcs hst alwaysQualify $
121 tcIfaceImports pcs hst get_fixity this_mod decls
122 ; printIfaceDump dflags maybe_tc_stuff
123 ; return maybe_tc_stuff }
125 this_mod = mi_module mod_iface
126 fixity_env = mi_fixities mod_iface
128 get_fixity :: Name -> Maybe Fixity
129 get_fixity nm = lookupNameEnv fixity_env nm
131 tcIfaceImports pcs hst get_fixity this_mod decls
132 = fixTc (\ ~(unf_env, _, _, _, _) ->
133 tcImports unf_env pcs hst get_fixity this_mod decls
134 ) `thenTc` \ (env, new_pcs, local_inst_info,
135 deriv_binds, local_rules) ->
136 ASSERT(nullBinds deriv_binds)
138 local_things = filter (isLocalThing this_mod)
139 (nameEnvElts (getTcGEnv env))
140 local_type_env :: TypeEnv
141 local_type_env = mkTypeEnv local_things
144 -- throw away local_inst_info
145 returnTc (new_pcs, local_type_env, local_rules)
148 typecheckExpr :: DynFlags
149 -> Bool -- True <=> wrap in 'print' to get a result of IO type
150 -> PersistentCompilerState
152 -> PrintUnqualified -- For error printing
155 RenamedHsExpr, -- The expression itself
156 [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files
157 -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr, TcType))
159 typecheckExpr dflags wrap_io pcs hst unqual this_mod (syn_map, expr, decls)
160 = typecheck dflags syn_map pcs hst unqual $
162 -- use the default default settings, i.e. [Integer, Double]
163 tcSetDefaultTys defaultDefaultTys $
165 -- Typecheck the extra declarations
166 fixTc (\ ~(unf_env, _, _, _, _) ->
167 tcImports unf_env pcs hst get_fixity this_mod decls
168 ) `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
169 ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules )
171 -- Now typecheck the expression
173 tc_expr expr `thenTc` \ (expr', expr_ty) ->
174 zonkExpr expr' `thenNF_Tc` \ zonked_expr ->
175 zonkTcType expr_ty `thenNF_Tc` \ zonked_ty ->
176 ioToTc (dumpIfSet_dyn dflags
177 Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_`
178 returnTc (new_pcs, zonked_expr, zonked_ty)
181 get_fixity :: Name -> Maybe Fixity
182 get_fixity n = pprPanic "typecheckExpr" (ppr n)
184 smpl_doc = ptext SLIT("main expression")
186 -- Typecheck it, wrapping in 'print' if necessary to
187 -- get a result of type IO t. Returns the result type
188 -- that is free in the result type
190 | wrap_io = tryTc_ (tc_io_expr (HsApp (HsVar printName) e)) -- Recovery case
191 (tc_io_expr e) -- Main case
192 | otherwise = newTyVarTy openTypeKind `thenTc` \ ty ->
193 tcMonoExpr e ty `thenTc` \ (e', lie) ->
194 tcSimplifyInfer smpl_doc (varSetElems (tyVarsOfType ty)) lie
195 `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) ->
196 tcSimplifyTop lie_free `thenTc` \ const_binds ->
197 let all_expr = mkHsLet const_binds $
202 all_expr_ty = mkForAllTys qtvs $
203 mkFunTys (map idType dict_ids) $
206 returnTc (all_expr, all_expr_ty)
208 tc_io_expr e = newTyVarTy openTypeKind `thenTc` \ ty ->
209 tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon ->
211 res_ty = mkTyConApp ioTyCon [ty]
213 tcMonoExpr e res_ty `thenTc` \ (e', lie) ->
214 tcSimplifyTop lie `thenTc` \ const_binds ->
215 let all_expr = mkHsLet const_binds e' in
216 returnTc (all_expr, res_ty)
219 typecheck :: DynFlags
221 -> PersistentCompilerState
223 -> PrintUnqualified -- For error printing
227 typecheck dflags syn_map pcs hst unqual thing_inside
228 = do { showPass dflags "Typechecker";
229 ; env <- initTcEnv syn_map hst (pcs_PTE pcs)
231 ; (maybe_tc_result, errs) <- initTc dflags env thing_inside
233 ; printErrorsAndWarnings unqual errs
235 ; if errorsFound errs then
238 return maybe_tc_result
242 The internal monster:
244 tcModule :: PersistentCompilerState
246 -> (Name -> Maybe Fixity)
249 -> TcM (PersistentCompilerState, TcResults)
251 tcModule pcs hst get_fixity this_mod decls
252 = fixTc (\ ~(unf_env, _, _) ->
253 -- Loop back the final environment, including the fully zonkec
254 -- versions of bindings from this module. In the presence of mutual
255 -- recursion, interface type signatures may mention variables defined
256 -- in this module, which is why the knot is so big
258 -- Type-check the type and class decls, and all imported decls
259 tcImports unf_env pcs hst get_fixity this_mod decls
260 `thenTc` \ (env, new_pcs, local_insts, deriv_binds, local_rules) ->
264 -- Foreign import declarations next
265 traceTc (text "Tc4") `thenNF_Tc_`
266 tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) ->
267 tcExtendGlobalValEnv fo_ids $
269 -- Default declarations
270 tcDefaults decls `thenTc` \ defaulting_tys ->
271 tcSetDefaultTys defaulting_tys $
273 -- Value declarations next.
274 -- We also typecheck any extra binds that came out of the "deriving" process
275 traceTc (text "Default types" <+> ppr defaulting_tys) `thenNF_Tc_`
276 traceTc (text "Tc5") `thenNF_Tc_`
277 tcTopBinds (val_binds `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env), lie_valdecls) ->
279 -- Second pass over class and instance declarations,
280 -- plus rules and foreign exports, to generate bindings
282 tcInstDecls2 local_insts `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
283 tcClassDecls2 this_mod tycl_decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
284 tcForeignExports decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) ->
285 tcSourceRules source_rules `thenNF_Tc` \ (lie_rules, more_local_rules) ->
287 -- Deal with constant or ambiguous InstIds. How could
288 -- there be ambiguous ones? They can only arise if a
289 -- top-level decl falls under the monomorphism
290 -- restriction, and no subsequent decl instantiates its
291 -- type. (Usually, ambiguous type variables are resolved
292 -- during the generalisation step.)
294 lie_alldecls = lie_valdecls `plusLIE`
295 lie_instdecls `plusLIE`
296 lie_clasdecls `plusLIE`
297 lie_fodecls `plusLIE`
300 traceTc (text "Tc6") `thenNF_Tc_`
301 tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds ->
303 -- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED
304 tcCheckMain this_mod `thenTc_`
306 -- Backsubstitution. This must be done last.
307 -- Even tcSimplifyTop may do some unification.
309 all_binds = val_binds `AndMonoBinds`
310 inst_binds `AndMonoBinds`
311 cls_dm_binds `AndMonoBinds`
312 const_inst_binds `AndMonoBinds`
315 traceTc (text "Tc7") `thenNF_Tc_`
316 zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', final_env) ->
318 -- zonkTopBinds puts all the top-level Ids into the tcGEnv
319 traceTc (text "Tc8") `thenNF_Tc_`
320 zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' ->
321 traceTc (text "Tc9") `thenNF_Tc_`
322 zonkRules more_local_rules `thenNF_Tc` \ more_local_rules' ->
325 let local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv final_env))
327 -- Create any necessary "implicit" bindings (data constructors etc)
328 -- Should we create bindings for dictionary constructors?
329 -- They are always fully applied, and the bindings are just there
330 -- to support partial applications. But it's easier to let them through.
331 implicit_binds = andMonoBindList [ CoreMonoBind id (unfoldingTemplate unf)
332 | id <- implicitTyThingIds local_things
333 , let unf = idUnfolding id
337 local_type_env :: TypeEnv
338 local_type_env = mkTypeEnv local_things
340 all_local_rules = local_rules ++ more_local_rules'
342 traceTc (text "Tc10") `thenNF_Tc_`
345 TcResults { tc_env = local_type_env,
346 tc_binds = implicit_binds `AndMonoBinds` all_binds',
347 tc_fords = foi_decls ++ foe_decls',
348 tc_rules = all_local_rules
351 ) `thenTc` \ (_, pcs, tc_result) ->
352 returnTc (pcs, tc_result)
354 tycl_decls = [d | TyClD d <- decls]
355 val_binds = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
356 source_rules = [d | RuleD d <- decls, not (isIfaceRuleDecl d)]
361 tcImports :: RecTcEnv
362 -> PersistentCompilerState
364 -> (Name -> Maybe Fixity)
367 -> TcM (TcEnv, PersistentCompilerState, [InstInfo],
368 RenamedHsBinds, [TypecheckedRuleDecl])
370 -- tcImports is a slight mis-nomer.
371 -- It deals with everythign that could be an import:
372 -- type and class decls
373 -- interface signatures
376 -- These can occur in source code too, of course
378 tcImports unf_env pcs hst get_fixity this_mod decls
379 -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
380 -- which is done lazily [ie failure just drops the pragma
381 -- without having any global-failure effect].
383 -- unf_env is also used to get the pragama info
384 -- for imported dfuns and default methods
387 -- tcImports recovers internally, but if anything gave rise to
388 -- an error we'd better stop now, to avoid a cascade
390 traceTc (text "Tc1") `thenNF_Tc_`
391 tcTyAndClassDecls unf_env tycl_decls `thenTc` \ env ->
394 -- Typecheck the instance decls, includes deriving
395 traceTc (text "Tc2") `thenNF_Tc_`
396 tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs)
397 hst unf_env get_fixity this_mod
398 decls `thenTc` \ (new_pcs_insts, inst_env, local_insts, deriv_binds) ->
399 tcSetInstEnv inst_env $
401 -- Interface type signatures
402 -- We tie a knot so that the Ids read out of interfaces are in scope
403 -- when we read their pragmas.
404 -- What we rely on is that pragmas are typechecked lazily; if
405 -- any type errors are found (ie there's an inconsistency)
406 -- we silently discard the pragma
407 traceTc (text "Tc3") `thenNF_Tc_`
408 tcInterfaceSigs unf_env tycl_decls `thenTc` \ sig_ids ->
409 tcExtendGlobalValEnv sig_ids $
412 tcIfaceRules (pcs_rules pcs) this_mod iface_rules `thenNF_Tc` \ (new_pcs_rules, local_rules) ->
413 -- When relinking this module from its interface-file decls
414 -- we'll have IfaceRules that are in fact local to this module
415 -- That's the reason we we get any local_rules out here
417 tcGetEnv `thenTc` \ unf_env ->
419 all_things = nameEnvElts (getTcGEnv unf_env)
421 -- sometimes we're compiling in the context of a package module
422 -- (on the GHCi command line, for example). In this case, we
423 -- want to treat everything we pulled in as an imported thing.
425 | isHomeModule this_mod
426 = filter (not . isLocalThing this_mod) all_things
430 new_pte :: PackageTypeEnv
431 new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
433 new_pcs :: PersistentCompilerState
434 new_pcs = pcs { pcs_PTE = new_pte,
435 pcs_insts = new_pcs_insts,
436 pcs_rules = new_pcs_rules
439 returnTc (unf_env, new_pcs, local_insts, deriv_binds, local_rules)
441 tycl_decls = [d | TyClD d <- decls]
442 iface_rules = [d | RuleD d <- decls, isIfaceRuleDecl d]
445 %************************************************************************
447 \subsection{Checking the type of main}
449 %************************************************************************
451 We must check that in module Main,
453 b) main :: forall a1...an. IO t, for some type t
457 then the type of main will be
459 and that should pass the test too.
461 So we just instantiate the type and unify with IO t, and declare
462 victory if doing so succeeds.
465 tcCheckMain :: Module -> TcM ()
467 | not (moduleName this_mod == mAIN_Name )
471 = -- First unify the main_id with IO t, for any old t
472 tcLookup_maybe mainName `thenNF_Tc` \ maybe_thing ->
474 Just (ATcId main_id) -> check_main_ty (idType main_id)
475 other -> addErrTc noMainErr
477 check_main_ty main_ty
478 = tcInstType main_ty `thenNF_Tc` \ (tvs, theta, main_tau) ->
479 newTyVarTy liftedTypeKind `thenNF_Tc` \ arg_ty ->
480 tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon ->
481 tcAddErrCtxtM (mainTypeCtxt main_ty) $
482 if not (null theta) then
483 failWithTc empty -- Context has the error message
485 unifyTauTy main_tau (mkTyConApp ioTyCon [arg_ty])
487 mainTypeCtxt main_ty tidy_env
488 = zonkTcType main_ty `thenNF_Tc` \ main_ty' ->
489 returnNF_Tc (tidy_env, ptext SLIT("`main' has the illegal type") <+>
490 quotes (ppr (tidyType tidy_env main_ty')))
492 noMainErr = hsep [ptext SLIT("Module") <+> quotes (ppr mAIN_Name),
493 ptext SLIT("must include a definition for") <+> quotes (ptext SLIT("main"))]
497 %************************************************************************
499 \subsection{Dumping output}
501 %************************************************************************
504 printTcDump dflags Nothing = return ()
505 printTcDump dflags (Just (_, results))
506 = do dumpIfSet_dyn dflags Opt_D_dump_types
507 "Type signatures" (dump_sigs (tc_env results))
508 dumpIfSet_dyn dflags Opt_D_dump_tc
509 "Typechecked" (dump_tc results)
511 printIfaceDump dflags Nothing = return ()
512 printIfaceDump dflags (Just (_, env, rules))
513 = do dumpIfSet_dyn dflags Opt_D_dump_types
514 "Type signatures" (dump_sigs env)
515 dumpIfSet_dyn dflags Opt_D_dump_tc
516 "Typechecked" (dump_iface env rules)
519 = vcat [ppr (tc_binds results),
520 pp_rules (tc_rules results),
521 ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)]
525 = vcat [pp_rules rules,
526 ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts env]
529 dump_sigs env -- Print type signatures
530 = -- Convert to HsType so that we get source-language style printing
531 -- And sort by RdrName
532 vcat $ map ppr_sig $ sortLt lt_sig $
533 [ (toRdrName id, toHsType (idType id))
534 | AnId id <- nameEnvElts env,
538 lt_sig (n1,_) (n2,_) = n1 < n2
539 ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t
541 want_sig id | opt_PprStyle_Debug = True
542 | otherwise = isLocalId id && isGlobalName (idName id)
543 -- isLocalId ignores data constructors, records selectors etc
544 -- The isGlobalName ignores local dictionary and method bindings
545 -- that the type checker has invented. User-defined things have
548 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
549 vcat (map ppr_gen_tycon tcs),
553 -- x&y are now Id's, not CoreExpr's
555 | Just ep <- tyConGenInfo tycon
556 = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
558 | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
561 = vcat [ ptext SLIT("Rep type:") <+> ppr (funResultTy from_tau),
562 ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
563 ptext SLIT("To:") <+> ppr (unfoldingTemplate (idUnfolding to))
566 (_,from_tau) = splitForAllTys (idType from)
569 pp_rules rs = vcat [ptext SLIT("{-# RULES"),
570 nest 4 (vcat (map ppr rs)),