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 ( 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, 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,
68 Outside-world interface:
71 -- Convenient type synonyms first:
74 -- All these fields have info *just for this module*
75 tc_env :: TypeEnv, -- The top level TypeEnv
76 tc_binds :: TypecheckedMonoBinds, -- Bindings
77 tc_fords :: [TypecheckedForeignDecl], -- Foreign import & exports.
78 tc_rules :: [TypecheckedRuleDecl] -- Transformation rules
84 -> PersistentCompilerState
86 -> ModIface -- Iface for this module
87 -> PrintUnqualified -- For error printing
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 decls
95 = do { maybe_tc_result <- typecheck dflags pcs hst unqual $
96 tcModule pcs hst get_fixity this_mod decls
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
113 -> (RenamedHsExpr, -- The expression itself
114 [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files
115 -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr, TcType))
117 typecheckExpr dflags wrap_io pcs hst unqual this_mod (expr, decls)
118 = typecheck dflags pcs hst unqual $
120 -- use the default default settings, i.e. [Integer, Double]
121 tcSetDefaultTys defaultDefaultTys $
122 tcImports pcs hst get_fixity this_mod decls `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
123 ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules )
126 tc_expr expr `thenTc` \ (expr', lie, expr_ty) ->
127 tcSimplifyInfer smpl_doc
128 (varSetElems (tyVarsOfType expr_ty)) lie `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) ->
129 tcSimplifyTop lie_free `thenTc` \ const_binds ->
130 let all_expr = mkHsLet const_binds $
135 all_expr_ty = mkForAllTys qtvs (mkFunTys (map idType dict_ids) expr_ty)
137 zonkExpr all_expr `thenNF_Tc` \ zonked_expr ->
138 zonkTcType all_expr_ty `thenNF_Tc` \ zonked_ty ->
139 ioToTc (dumpIfSet_dyn dflags
140 Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_`
141 returnTc (new_pcs, zonked_expr, zonked_ty)
144 get_fixity :: Name -> Maybe Fixity
145 get_fixity n = pprPanic "typecheckExpr" (ppr n)
147 smpl_doc = ptext SLIT("main expression")
149 -- Typecheck it, wrapping in 'print' if necessary to
150 -- get a result of type IO t. Returns the result type
151 -- that is free in the result type
153 | wrap_io = tryTc_ (tc_io_expr (HsApp (HsVar printName) e)) -- Recovery case
154 (tc_io_expr e) -- Main case
155 | otherwise = newTyVarTy openTypeKind `thenTc` \ ty ->
156 tcMonoExpr e ty `thenTc` \ (e', lie) ->
157 returnTc (e', lie, ty)
160 tc_io_expr e = newTyVarTy openTypeKind `thenTc` \ ty ->
161 tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon ->
163 res_ty = mkTyConApp ioTyCon [ty]
165 tcMonoExpr e res_ty `thenTc` \ (e', lie) ->
166 returnTc (e', lie, res_ty)
169 typecheck :: DynFlags
170 -> PersistentCompilerState
172 -> PrintUnqualified -- For error printing
176 typecheck dflags pcs hst unqual thing_inside
177 = do { showPass dflags "Typechecker";
178 ; env <- initTcEnv hst (pcs_PTE pcs)
180 ; (maybe_tc_result, errs) <- initTc dflags env thing_inside
182 ; printErrorsAndWarnings unqual errs
184 ; if errorsFound errs then
187 return maybe_tc_result
191 The internal monster:
193 tcModule :: PersistentCompilerState
195 -> (Name -> Maybe Fixity)
198 -> TcM (PersistentCompilerState, TcResults)
200 tcModule pcs hst get_fixity this_mod decls
201 = -- Type-check the type and class decls, and all imported decls
202 -- tcImports recovers internally, but if anything gave rise to
203 -- an error we'd better stop now, to avoid a cascade
205 tcImports pcs hst get_fixity this_mod decls
206 ) `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
210 -- Foreign import declarations next
211 -- traceTc (text "Tc4") `thenNF_Tc_`
212 tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) ->
213 tcExtendGlobalValEnv fo_ids $
215 -- Default declarations
216 tcDefaults decls `thenTc` \ defaulting_tys ->
217 tcSetDefaultTys defaulting_tys $
219 -- Value declarations next.
220 -- We also typecheck any extra binds that came out of the "deriving" process
221 -- traceTc (text "Tc5") `thenNF_Tc_`
222 tcTopBinds (val_binds `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env), lie_valdecls) ->
225 -- Foreign export declarations next
226 -- traceTc (text "Tc6") `thenNF_Tc_`
227 tcForeignExports decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) ->
229 -- Second pass over class and instance declarations,
230 -- to compile the bindings themselves.
231 tcInstDecls2 local_inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
232 tcClassDecls2 this_mod tycl_decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
233 tcSourceRules source_rules `thenNF_Tc` \ (lie_rules, more_local_rules) ->
235 -- Deal with constant or ambiguous InstIds. How could
236 -- there be ambiguous ones? They can only arise if a
237 -- top-level decl falls under the monomorphism
238 -- restriction, and no subsequent decl instantiates its
239 -- type. (Usually, ambiguous type variables are resolved
240 -- during the generalisation step.)
242 lie_alldecls = lie_valdecls `plusLIE`
243 lie_instdecls `plusLIE`
244 lie_clasdecls `plusLIE`
245 lie_fodecls `plusLIE`
248 tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds ->
250 -- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED
251 tcCheckMain this_mod `thenTc_`
253 -- Backsubstitution. This must be done last.
254 -- Even tcSimplifyTop may do some unification.
256 all_binds = val_binds `AndMonoBinds`
257 inst_binds `AndMonoBinds`
258 cls_dm_binds `AndMonoBinds`
259 const_inst_binds `AndMonoBinds`
262 -- traceTc (text "Tc9") `thenNF_Tc_`
263 zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', final_env) ->
265 -- zonkTopBinds puts all the top-level Ids into the tcGEnv
266 zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' ->
267 zonkRules more_local_rules `thenNF_Tc` \ more_local_rules' ->
270 let local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv final_env))
272 -- Create any necessary "implicit" bindings (data constructors etc)
273 -- Should we create bindings for dictionary constructors?
274 -- They are always fully applied, and the bindings are just there
275 -- to support partial applications. But it's easier to let them through.
276 implicit_binds = andMonoBindList [ CoreMonoBind id (unfoldingTemplate unf)
277 | id <- implicitTyThingIds local_things
278 , let unf = idUnfolding id
282 local_type_env :: TypeEnv
283 local_type_env = mkTypeEnv local_things
285 all_local_rules = local_rules ++ more_local_rules'
287 -- traceTc (text "Tc10") `thenNF_Tc_`
289 TcResults { tc_env = local_type_env,
290 tc_binds = implicit_binds `AndMonoBinds` all_binds',
291 tc_fords = foi_decls ++ foe_decls',
292 tc_rules = all_local_rules
296 tycl_decls = [d | TyClD d <- decls]
297 val_binds = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
298 source_rules = [d | RuleD d <- decls, not (isIfaceRuleDecl d)]
303 tcImports :: PersistentCompilerState
305 -> (Name -> Maybe Fixity)
308 -> TcM (TcEnv, PersistentCompilerState,
309 [InstInfo], RenamedHsBinds, [TypecheckedRuleDecl])
311 -- tcImports is a slight mis-nomer.
312 -- It deals with everythign that could be an import:
313 -- type and class decls
314 -- interface signatures
317 -- These can occur in source code too, of course
319 tcImports pcs hst get_fixity this_mod decls
320 = fixTc (\ ~(unf_env, _, _, _, _) ->
321 -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
322 -- which is done lazily [ie failure just drops the pragma
323 -- without having any global-failure effect].
325 -- unf_env is also used to get the pragama info
326 -- for imported dfuns and default methods
328 -- traceTc (text "Tc1") `thenNF_Tc_`
329 tcTyAndClassDecls unf_env tycl_decls `thenTc` \ env ->
332 -- Typecheck the instance decls, includes deriving
333 -- traceTc (text "Tc2") `thenNF_Tc_`
334 tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs)
335 hst unf_env get_fixity this_mod
336 decls `thenTc` \ (new_pcs_insts, inst_env, local_inst_info, deriv_binds) ->
337 tcSetInstEnv inst_env $
339 -- Interface type signatures
340 -- We tie a knot so that the Ids read out of interfaces are in scope
341 -- when we read their pragmas.
342 -- What we rely on is that pragmas are typechecked lazily; if
343 -- any type errors are found (ie there's an inconsistency)
344 -- we silently discard the pragma
345 -- traceTc (text "Tc3") `thenNF_Tc_`
346 tcInterfaceSigs unf_env tycl_decls `thenTc` \ sig_ids ->
347 tcExtendGlobalValEnv sig_ids $
350 tcIfaceRules (pcs_rules pcs) this_mod iface_rules `thenNF_Tc` \ (new_pcs_rules, local_rules) ->
351 -- When relinking this module from its interface-file decls
352 -- we'll have IfaceRules that are in fact local to this module
353 -- That's the reason we we get any local_rules out here
355 tcGetEnv `thenTc` \ unf_env ->
357 all_things = nameEnvElts (getTcGEnv unf_env)
359 -- sometimes we're compiling in the context of a package module
360 -- (on the GHCi command line, for example). In this case, we
361 -- want to treat everything we pulled in as an imported thing.
363 | isHomeModule this_mod
364 = filter (not . isLocalThing this_mod) all_things
368 new_pte :: PackageTypeEnv
369 new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
371 new_pcs :: PersistentCompilerState
372 new_pcs = pcs { pcs_PTE = new_pte,
373 pcs_insts = new_pcs_insts,
374 pcs_rules = new_pcs_rules
377 returnTc (unf_env, new_pcs, local_inst_info, deriv_binds, local_rules)
380 tycl_decls = [d | TyClD d <- decls]
381 iface_rules = [d | RuleD d <- decls, isIfaceRuleDecl d]
384 %************************************************************************
386 \subsection{Checking the type of main}
388 %************************************************************************
390 We must check that in module Main,
392 b) main :: forall a1...an. IO t, for some type t
396 then the type of main will be
398 and that should pass the test too.
400 So we just instantiate the type and unify with IO t, and declare
401 victory if doing so succeeds.
404 tcCheckMain :: Module -> TcM ()
406 | not (moduleName this_mod == mAIN_Name )
410 = -- First unify the main_id with IO t, for any old t
411 tcLookup_maybe mainName `thenNF_Tc` \ maybe_thing ->
413 Just (ATcId main_id) -> check_main_ty (idType main_id)
414 other -> addErrTc noMainErr
416 check_main_ty main_ty
417 = tcInstType main_ty `thenNF_Tc` \ (tvs, theta, main_tau) ->
418 newTyVarTy liftedTypeKind `thenNF_Tc` \ arg_ty ->
419 tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon ->
420 tcAddErrCtxtM (mainTypeCtxt main_ty) $
421 if not (null theta) then
422 failWithTc empty -- Context has the error message
424 unifyTauTy main_tau (mkTyConApp ioTyCon [arg_ty])
426 mainTypeCtxt main_ty tidy_env
427 = zonkTcType main_ty `thenNF_Tc` \ main_ty' ->
428 returnNF_Tc (tidy_env, ptext SLIT("`main' has the illegal type") <+>
429 quotes (ppr (tidyType tidy_env main_ty')))
431 noMainErr = hsep [ptext SLIT("Module") <+> quotes (ppr mAIN_Name),
432 ptext SLIT("must include a definition for") <+> quotes (ptext SLIT("main"))]
436 %************************************************************************
438 \subsection{Dumping output}
440 %************************************************************************
443 printTcDump dflags Nothing = return ()
444 printTcDump dflags (Just (_, results))
445 = do dumpIfSet_dyn dflags Opt_D_dump_types
446 "Type signatures" (dump_sigs results)
447 dumpIfSet_dyn dflags Opt_D_dump_tc
448 "Typechecked" (dump_tc results)
451 = vcat [ppr (tc_binds results),
452 pp_rules (tc_rules results),
453 ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)]
456 dump_sigs results -- Print type signatures
457 = -- Convert to HsType so that we get source-language style printing
458 -- And sort by RdrName
459 vcat $ map ppr_sig $ sortLt lt_sig $
460 [ (toRdrName id, toHsType (idType id))
461 | AnId id <- nameEnvElts (tc_env results),
465 lt_sig (n1,_) (n2,_) = n1 < n2
466 ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t
468 want_sig id | opt_PprStyle_Debug = True
469 | otherwise = isLocalId id && isGlobalName (idName id)
470 -- isLocalId ignores data constructors, records selectors etc
471 -- The isGlobalName ignores local dictionary and method bindings
472 -- that the type checker has invented. User-defined things have
475 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
476 vcat (map ppr_gen_tycon tcs),
480 -- x&y are now Id's, not CoreExpr's
482 | Just ep <- tyConGenInfo tycon
483 = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
485 | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
488 = vcat [ ptext SLIT("Rep type:") <+> ppr (funResultTy from_tau),
489 ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
490 ptext SLIT("To:") <+> ppr (unfoldingTemplate (idUnfolding to))
493 (_,from_tau) = splitForAllTys (idType from)
496 pp_rules rs = vcat [ptext SLIT("{-# RULES"),
497 nest 4 (vcat (map ppr rs)),