2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcModule]{Typechecking a whole module}
8 typecheckModule, 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
86 -> PrintUnqualified -- For error printing
87 -> (SyntaxMap, [RenamedHsDecl])
88 -> Bool -- True <=> check for Main.main if Module==Main
89 -> IO (Maybe (PersistentCompilerState, TcResults))
90 -- The new PCS is Augmented with imported information,
91 -- (but not stuff from this module)
94 typecheckModule dflags pcs hst mod_iface unqual (syn_map, decls) check_main
95 = do { maybe_tc_result <- typecheck dflags syn_map pcs hst unqual $
96 tcModule pcs hst get_fixity this_mod decls check_main
97 ; printTcDump dflags maybe_tc_result
98 ; return maybe_tc_result }
100 this_mod = mi_module mod_iface
101 fixity_env = mi_fixities mod_iface
103 get_fixity :: Name -> Maybe Fixity
104 get_fixity nm = lookupNameEnv fixity_env nm
107 typecheckExpr :: DynFlags
108 -> Bool -- True <=> wrap in 'print' to get a result of IO type
109 -> PersistentCompilerState
111 -> PrintUnqualified -- For error printing
114 RenamedHsExpr, -- The expression itself
115 [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files
116 -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr, TcType))
118 typecheckExpr dflags wrap_io pcs hst unqual this_mod (syn_map, expr, decls)
119 = typecheck dflags syn_map pcs hst unqual $
121 -- use the default default settings, i.e. [Integer, Double]
122 tcSetDefaultTys defaultDefaultTys $
124 -- Typecheck the extra declarations
125 fixTc (\ ~(unf_env, _, _, _, _) ->
126 tcImports unf_env pcs hst get_fixity this_mod decls
127 ) `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
128 ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules )
130 -- Now typecheck the expression
132 tc_expr expr `thenTc` \ (expr', expr_ty) ->
133 zonkExpr expr' `thenNF_Tc` \ zonked_expr ->
134 zonkTcType expr_ty `thenNF_Tc` \ zonked_ty ->
135 ioToTc (dumpIfSet_dyn dflags
136 Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_`
137 returnTc (new_pcs, zonked_expr, zonked_ty)
140 get_fixity :: Name -> Maybe Fixity
141 get_fixity n = pprPanic "typecheckExpr" (ppr n)
143 smpl_doc = ptext SLIT("main expression")
145 -- Typecheck it, wrapping in 'print' if necessary to
146 -- get a result of type IO t. Returns the result type
147 -- that is free in the result type
149 | wrap_io = tryTc_ (tc_io_expr (HsApp (HsVar printName) e)) -- Recovery case
150 (tc_io_expr e) -- Main case
151 | otherwise = newTyVarTy openTypeKind `thenTc` \ ty ->
152 tcMonoExpr e ty `thenTc` \ (e', lie) ->
153 tcSimplifyInfer smpl_doc (varSetElems (tyVarsOfType ty)) lie
154 `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) ->
155 tcSimplifyTop lie_free `thenTc` \ const_binds ->
156 let all_expr = mkHsLet const_binds $
161 all_expr_ty = mkForAllTys qtvs $
162 mkFunTys (map idType dict_ids) $
165 returnTc (all_expr, all_expr_ty)
167 tc_io_expr e = newTyVarTy openTypeKind `thenTc` \ ty ->
168 tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon ->
170 res_ty = mkTyConApp ioTyCon [ty]
172 tcMonoExpr e res_ty `thenTc` \ (e', lie) ->
173 tcSimplifyTop lie `thenTc` \ const_binds ->
174 let all_expr = mkHsLet const_binds e' in
175 returnTc (all_expr, res_ty)
178 typecheck :: DynFlags
180 -> PersistentCompilerState
182 -> PrintUnqualified -- For error printing
186 typecheck dflags syn_map pcs hst unqual thing_inside
187 = do { showPass dflags "Typechecker";
188 ; env <- initTcEnv syn_map hst (pcs_PTE pcs)
190 ; (maybe_tc_result, errs) <- initTc dflags env thing_inside
192 ; printErrorsAndWarnings unqual errs
194 ; if errorsFound errs then
197 return maybe_tc_result
201 The internal monster:
203 tcModule :: PersistentCompilerState
205 -> (Name -> Maybe Fixity)
208 -> Bool -- True <=> check for Main.main if Mod==Main
209 -> TcM (PersistentCompilerState, TcResults)
211 tcModule pcs hst get_fixity this_mod decls check_main
212 = fixTc (\ ~(unf_env, _, _) ->
213 -- Loop back the final environment, including the fully zonkec
214 -- versions of bindings from this module. In the presence of mutual
215 -- recursion, interface type signatures may mention variables defined
216 -- in this module, which is why the knot is so big
218 -- Type-check the type and class decls, and all imported decls
219 tcImports unf_env pcs hst get_fixity this_mod decls
220 `thenTc` \ (env, new_pcs, local_insts, deriv_binds, local_rules) ->
224 -- Foreign import declarations next
225 traceTc (text "Tc4") `thenNF_Tc_`
226 tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) ->
227 tcExtendGlobalValEnv fo_ids $
229 -- Default declarations
230 tcDefaults decls `thenTc` \ defaulting_tys ->
231 tcSetDefaultTys defaulting_tys $
233 -- Value declarations next.
234 -- We also typecheck any extra binds that came out of the "deriving" process
235 traceTc (text "Default types" <+> ppr defaulting_tys) `thenNF_Tc_`
236 traceTc (text "Tc5") `thenNF_Tc_`
237 tcTopBinds (val_binds `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env), lie_valdecls) ->
239 -- Second pass over class and instance declarations,
240 -- plus rules and foreign exports, to generate bindings
242 tcInstDecls2 local_insts `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
243 tcClassDecls2 this_mod tycl_decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
244 tcForeignExports decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) ->
245 tcSourceRules source_rules `thenNF_Tc` \ (lie_rules, more_local_rules) ->
247 -- Deal with constant or ambiguous InstIds. How could
248 -- there be ambiguous ones? They can only arise if a
249 -- top-level decl falls under the monomorphism
250 -- restriction, and no subsequent decl instantiates its
251 -- type. (Usually, ambiguous type variables are resolved
252 -- during the generalisation step.)
254 lie_alldecls = lie_valdecls `plusLIE`
255 lie_instdecls `plusLIE`
256 lie_clasdecls `plusLIE`
257 lie_fodecls `plusLIE`
260 traceTc (text "Tc6") `thenNF_Tc_`
261 tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds ->
263 -- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED
265 then tcCheckMain this_mod
266 else returnTc ()) `thenTc_`
268 -- Backsubstitution. This must be done last.
269 -- Even tcSimplifyTop may do some unification.
271 all_binds = val_binds `AndMonoBinds`
272 inst_binds `AndMonoBinds`
273 cls_dm_binds `AndMonoBinds`
274 const_inst_binds `AndMonoBinds`
277 traceTc (text "Tc7") `thenNF_Tc_`
278 zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', final_env) ->
280 -- zonkTopBinds puts all the top-level Ids into the tcGEnv
281 traceTc (text "Tc8") `thenNF_Tc_`
282 zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' ->
283 traceTc (text "Tc9") `thenNF_Tc_`
284 zonkRules more_local_rules `thenNF_Tc` \ more_local_rules' ->
287 let local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv final_env))
289 -- Create any necessary "implicit" bindings (data constructors etc)
290 -- Should we create bindings for dictionary constructors?
291 -- They are always fully applied, and the bindings are just there
292 -- to support partial applications. But it's easier to let them through.
293 implicit_binds = andMonoBindList [ CoreMonoBind id (unfoldingTemplate unf)
294 | id <- implicitTyThingIds local_things
295 , let unf = idUnfolding id
299 local_type_env :: TypeEnv
300 local_type_env = mkTypeEnv local_things
302 all_local_rules = local_rules ++ more_local_rules'
304 traceTc (text "Tc10") `thenNF_Tc_`
307 TcResults { tc_env = local_type_env,
308 tc_binds = implicit_binds `AndMonoBinds` all_binds',
309 tc_fords = foi_decls ++ foe_decls',
310 tc_rules = all_local_rules
313 ) `thenTc` \ (_, pcs, tc_result) ->
314 returnTc (pcs, tc_result)
316 tycl_decls = [d | TyClD d <- decls]
317 val_binds = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
318 source_rules = [d | RuleD d <- decls, not (isIfaceRuleDecl d)]
323 tcImports :: RecTcEnv
324 -> PersistentCompilerState
326 -> (Name -> Maybe Fixity)
329 -> TcM (TcEnv, PersistentCompilerState, [InstInfo],
330 RenamedHsBinds, [TypecheckedRuleDecl])
332 -- tcImports is a slight mis-nomer.
333 -- It deals with everythign that could be an import:
334 -- type and class decls
335 -- interface signatures
338 -- These can occur in source code too, of course
340 tcImports unf_env pcs hst get_fixity this_mod decls
341 -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
342 -- which is done lazily [ie failure just drops the pragma
343 -- without having any global-failure effect].
345 -- unf_env is also used to get the pragama info
346 -- for imported dfuns and default methods
349 -- tcImports recovers internally, but if anything gave rise to
350 -- an error we'd better stop now, to avoid a cascade
352 traceTc (text "Tc1") `thenNF_Tc_`
353 tcTyAndClassDecls unf_env tycl_decls `thenTc` \ env ->
356 -- Typecheck the instance decls, includes deriving
357 traceTc (text "Tc2") `thenNF_Tc_`
358 tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs)
359 hst unf_env get_fixity this_mod
360 decls `thenTc` \ (new_pcs_insts, inst_env, local_insts, deriv_binds) ->
361 tcSetInstEnv inst_env $
363 -- Interface type signatures
364 -- We tie a knot so that the Ids read out of interfaces are in scope
365 -- when we read their pragmas.
366 -- What we rely on is that pragmas are typechecked lazily; if
367 -- any type errors are found (ie there's an inconsistency)
368 -- we silently discard the pragma
369 traceTc (text "Tc3") `thenNF_Tc_`
370 tcInterfaceSigs unf_env tycl_decls `thenTc` \ sig_ids ->
371 tcExtendGlobalValEnv sig_ids $
374 tcIfaceRules (pcs_rules pcs) this_mod iface_rules `thenNF_Tc` \ (new_pcs_rules, local_rules) ->
375 -- When relinking this module from its interface-file decls
376 -- we'll have IfaceRules that are in fact local to this module
377 -- That's the reason we we get any local_rules out here
379 tcGetEnv `thenTc` \ unf_env ->
381 all_things = nameEnvElts (getTcGEnv unf_env)
383 -- sometimes we're compiling in the context of a package module
384 -- (on the GHCi command line, for example). In this case, we
385 -- want to treat everything we pulled in as an imported thing.
387 | isHomeModule this_mod
388 = filter (not . isLocalThing this_mod) all_things
392 new_pte :: PackageTypeEnv
393 new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
395 new_pcs :: PersistentCompilerState
396 new_pcs = pcs { pcs_PTE = new_pte,
397 pcs_insts = new_pcs_insts,
398 pcs_rules = new_pcs_rules
401 returnTc (unf_env, new_pcs, local_insts, deriv_binds, local_rules)
403 tycl_decls = [d | TyClD d <- decls]
404 iface_rules = [d | RuleD d <- decls, isIfaceRuleDecl d]
407 %************************************************************************
409 \subsection{Checking the type of main}
411 %************************************************************************
413 We must check that in module Main,
415 b) main :: forall a1...an. IO t, for some type t
419 then the type of main will be
421 and that should pass the test too.
423 So we just instantiate the type and unify with IO t, and declare
424 victory if doing so succeeds.
427 tcCheckMain :: Module -> TcM ()
429 | not (moduleName this_mod == mAIN_Name )
433 = -- First unify the main_id with IO t, for any old t
434 tcLookup_maybe mainName `thenNF_Tc` \ maybe_thing ->
436 Just (ATcId main_id) -> check_main_ty (idType main_id)
437 other -> addErrTc noMainErr
439 check_main_ty main_ty
440 = tcInstType main_ty `thenNF_Tc` \ (tvs, theta, main_tau) ->
441 newTyVarTy liftedTypeKind `thenNF_Tc` \ arg_ty ->
442 tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon ->
443 tcAddErrCtxtM (mainTypeCtxt main_ty) $
444 if not (null theta) then
445 failWithTc empty -- Context has the error message
447 unifyTauTy main_tau (mkTyConApp ioTyCon [arg_ty])
449 mainTypeCtxt main_ty tidy_env
450 = zonkTcType main_ty `thenNF_Tc` \ main_ty' ->
451 returnNF_Tc (tidy_env, ptext SLIT("`main' has the illegal type") <+>
452 quotes (ppr (tidyType tidy_env main_ty')))
454 noMainErr = hsep [ptext SLIT("Module") <+> quotes (ppr mAIN_Name),
455 ptext SLIT("must include a definition for") <+> quotes (ptext SLIT("main"))]
459 %************************************************************************
461 \subsection{Dumping output}
463 %************************************************************************
466 printTcDump dflags Nothing = return ()
467 printTcDump dflags (Just (_, results))
468 = do dumpIfSet_dyn dflags Opt_D_dump_types
469 "Type signatures" (dump_sigs results)
470 dumpIfSet_dyn dflags Opt_D_dump_tc
471 "Typechecked" (dump_tc results)
474 = vcat [ppr (tc_binds results),
475 pp_rules (tc_rules results),
476 ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)]
479 dump_sigs results -- Print type signatures
480 = -- Convert to HsType so that we get source-language style printing
481 -- And sort by RdrName
482 vcat $ map ppr_sig $ sortLt lt_sig $
483 [ (toRdrName id, toHsType (idType id))
484 | AnId id <- nameEnvElts (tc_env results),
488 lt_sig (n1,_) (n2,_) = n1 < n2
489 ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t
491 want_sig id | opt_PprStyle_Debug = True
492 | otherwise = isLocalId id && isGlobalName (idName id)
493 -- isLocalId ignores data constructors, records selectors etc
494 -- The isGlobalName ignores local dictionary and method bindings
495 -- that the type checker has invented. User-defined things have
498 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
499 vcat (map ppr_gen_tycon tcs),
503 -- x&y are now Id's, not CoreExpr's
505 | Just ep <- tyConGenInfo tycon
506 = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
508 | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
511 = vcat [ ptext SLIT("Rep type:") <+> ppr (funResultTy from_tau),
512 ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
513 ptext SLIT("To:") <+> ppr (unfoldingTemplate (idUnfolding to))
516 (_,from_tau) = splitForAllTys (idType from)
519 pp_rules rs = vcat [ptext SLIT("{-# RULES"),
520 nest 4 (vcat (map ppr rs)),