2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcModule]{Typechecking a whole module}
7 #include "HsVersions.h"
12 SYN_IE(TcSpecialiseRequests),
18 import HsSyn ( HsDecl(..), HsModule(..), HsBinds(..), HsExpr, MonoBinds(..),
19 TyDecl, SpecDataSig, ClassDecl, InstDecl, IfaceSig,
20 SpecInstSig, DefaultDecl, Sig, Fake, InPat,
21 SYN_IE(RecFlag), nonRecursive, GRHSsAndBinds, Match,
22 FixityDecl, IE, ImportDecl
24 import RnHsSyn ( SYN_IE(RenamedHsModule), RenamedFixityDecl(..) )
25 import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
26 SYN_IE(TypecheckedDictBinds), SYN_IE(TcMonoBinds),
27 SYN_IE(TypecheckedMonoBinds),
28 TcIdOcc(..), zonkTopBinds )
31 import Inst ( Inst, emptyLIE, plusLIE )
32 import TcBinds ( tcBindsAndThen )
33 import TcClassDcl ( tcClassDecls2 )
34 import TcDefaults ( tcDefaults )
35 import TcEnv ( tcExtendGlobalValEnv, getEnv_LocalIds,
36 getEnv_TyCons, getEnv_Classes, tcLookupLocalValue,
37 tcLookupLocalValueByKey, tcLookupTyCon,
38 tcLookupGlobalValueByKeyMaybe )
39 import SpecEnv ( SpecEnv )
40 import TcExpr ( tcId )
41 import TcIfaceSig ( tcInterfaceSigs )
42 import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
43 import TcInstUtil ( buildInstanceEnvs, InstInfo )
44 import TcSimplify ( tcSimplifyTop )
45 import TcTyClsDecls ( tcTyAndClassDecls1 )
46 import TcTyDecls ( mkDataBinds )
47 import TcType ( SYN_IE(TcType), tcInstType )
48 import TcKind ( TcKind )
50 import RnMonad ( RnNameSupply(..) )
51 import Bag ( listToBag )
52 import ErrUtils ( SYN_IE(Warning), SYN_IE(Error) )
53 import Id ( idType, GenId, SYN_IE(IdEnv), nullIdEnv )
54 import Maybes ( catMaybes, MaybeErr )
55 import Name ( Name, isLocallyDefined, pprModule )
57 import TyCon ( TyCon, isSynTyCon )
58 import Class ( GenClass, SYN_IE(Class), classSelIds )
59 import Type ( applyTyCon, mkSynTy, SYN_IE(Type) )
60 import PprType ( GenType, GenTyVar )
61 import TysWiredIn ( unitTy )
62 import PrelMods ( gHC_MAIN, mAIN )
63 import PrelInfo ( main_NAME, mainPrimIO_NAME, ioTyCon_NAME, primIoTyCon_NAME )
64 import TyVar ( GenTyVar, SYN_IE(TyVarEnv), nullTyVarEnv )
65 import Unify ( unifyTauTy )
66 import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
68 import Unique ( Unique )
69 import UniqSupply ( UniqSupply )
71 import Bag ( Bag, isEmptyBag )
73 import FiniteMap ( emptyFM, FiniteMap )
75 import Outputable ( Outputable(..), PprStyle )
80 Outside-world interface:
82 --ToDo: put this in HsVersions
83 #if __GLASGOW_HASKELL__ >= 200
84 # define REAL_WORLD RealWorld
86 # define REAL_WORLD _RealWorld
90 -- Convenient type synonyms first:
92 = (TypecheckedMonoBinds,
94 Bag InstInfo, -- Instance declaration information
98 type TcSpecialiseRequests
99 = FiniteMap TyCon [(Bool, [Maybe Type])]
100 -- source tycon specialisation requests
111 (TcResults, -- if all goes well...
112 Bag Warning) -- (we can still get warnings)
113 (Bag Error, -- if we had errors...
116 typecheckModule us rn_name_supply mod
117 = initTc us (tcModule rn_name_supply mod)
120 The internal monster:
122 tcModule :: RnNameSupply -- for renaming derivings
123 -> RenamedHsModule -- input
124 -> TcM s TcResults -- output
126 tcModule rn_name_supply
127 (HsModule mod_name verion exports imports fixities decls src_loc)
128 = tcAddSrcLoc src_loc $ -- record where we're starting
130 fixTc (\ ~(unf_env ,_) ->
131 -- unf_env is used for type-checking interface pragmas
132 -- which is done lazily [ie failure just drops the pragma
133 -- without having any global-failure effect].
135 -- unf_env is also used to get the pragam info for dfuns.
137 -- The knot for instance information. This isn't used at all
138 -- till we type-check value declarations
139 fixTc ( \ ~(rec_inst_mapper, _, _, _, _) ->
141 -- Type-check the type and class decls
142 -- trace "tcTyAndClassDecls:" $
143 tcTyAndClassDecls1 unf_env rec_inst_mapper decls `thenTc` \ env ->
146 -- Typecheck the instance decls, includes deriving
148 -- trace "tcInstDecls:" $
149 tcInstDecls1 unf_env decls mod_name rn_name_supply
150 ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
153 buildInstanceEnvs inst_info `thenTc` \ inst_mapper ->
155 returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
157 -- End of inner fix loop
158 ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
163 -- Default declarations
164 tcDefaults decls `thenTc` \ defaulting_tys ->
165 tcSetDefaultTys defaulting_tys $
167 -- Create any necessary record selector Ids and their bindings
168 -- "Necessary" includes data and newtype declarations
170 tycons = getEnv_TyCons env
171 classes = getEnv_Classes env
173 mkDataBinds tycons `thenTc` \ (data_ids, data_binds) ->
175 -- Extend the global value environment with
177 -- (b) record selectors
178 -- (c) class op selectors
179 -- (d) default-method ids
180 tcExtendGlobalValEnv data_ids $
181 tcExtendGlobalValEnv (concat (map classSelIds classes)) $
184 -- Interface type signatures
185 -- We tie a knot so that the Ids read out of interfaces are in scope
186 -- when we read their pragmas.
187 -- What we rely on is that pragmas are typechecked lazily; if
188 -- any type errors are found (ie there's an inconsistency)
189 -- we silently discard the pragma
190 tcInterfaceSigs unf_env decls `thenTc` \ sig_ids ->
191 tcExtendGlobalValEnv sig_ids $
194 -- Value declarations next.
195 -- We also typecheck any extra binds that came out of the "deriving" process
196 -- trace "tcBinds:" $
198 (\ is_rec binds1 (binds2, thing) -> (binds1 `AndMonoBinds` binds2, thing))
199 (get_val_decls decls `ThenBinds` deriv_binds)
200 ( tcGetEnv `thenNF_Tc` \ env ->
201 returnTc ((EmptyMonoBinds, env), emptyLIE)
202 ) `thenTc` \ ((val_binds, final_env), lie_valdecls) ->
206 -- Second pass over class and instance declarations,
207 -- to compile the bindings themselves.
209 tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
210 tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
214 -- Check that "main" has the right signature
215 tcCheckMainSig mod_name `thenTc_`
217 -- Deal with constant or ambiguous InstIds. How could
218 -- there be ambiguous ones? They can only arise if a
219 -- top-level decl falls under the monomorphism
220 -- restriction, and no subsequent decl instantiates its
221 -- type. (Usually, ambiguous type variables are resolved
222 -- during the generalisation step.)
225 lie_alldecls = lie_valdecls `plusLIE` lie_instdecls `plusLIE` lie_clasdecls
227 tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds ->
230 -- Backsubstitution. This must be done last.
231 -- Even tcCheckMainSig and tcSimplifyTop may do some unification.
233 all_binds = data_binds `AndMonoBinds`
234 val_binds `AndMonoBinds`
235 inst_binds `AndMonoBinds`
236 cls_binds `AndMonoBinds`
239 zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', really_final_env) ->
241 returnTc (really_final_env, (all_binds', inst_info, ddump_deriv))
243 -- End of outer fix loop
244 ) `thenTc` \ (final_env, (all_binds', inst_info, ddump_deriv)) ->
248 tycons = getEnv_TyCons final_env
249 classes = getEnv_Classes final_env
251 local_tycons = filter isLocallyDefined tycons
252 local_classes = filter isLocallyDefined classes
258 local_tycons, local_classes, inst_info, tycon_specs,
263 get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
268 tcCheckMainSig mod_name
269 | not is_main && not is_ghc_main
270 = returnTc () -- A non-main module
273 = -- Check that main is defined
274 tcLookupTyCon tycon_name `thenTc` \ (_,_,tycon) ->
275 tcLookupLocalValue main_name `thenNF_Tc` \ maybe_main_id ->
276 case maybe_main_id of {
277 Nothing -> failTc (noMainErr mod_name main_name);
280 -- Check that it has the right type (or a more general one)
282 expected_ty | isSynTyCon tycon = mkSynTy tycon [unitTy]
283 | otherwise = applyTyCon tycon [unitTy]
284 -- This is bizarre. There ought to be a suitable function in Type.lhs!
286 tcInstType [] expected_ty `thenNF_Tc` \ expected_tau ->
287 tcId main_name `thenNF_Tc` \ (_, lie, main_tau) ->
288 tcSetErrCtxt (mainTyCheckCtxt main_name) $
289 unifyTauTy expected_tau
291 checkTc (isEmptyBag lie) (mainTyMisMatch main_name expected_ty (idType main_id))
294 is_main = mod_name == mAIN
295 is_ghc_main = mod_name == gHC_MAIN
297 main_name | is_main = main_NAME
298 | otherwise = mainPrimIO_NAME
300 tycon_name | is_main = ioTyCon_NAME
301 | otherwise = primIoTyCon_NAME
303 mainTyCheckCtxt main_name sty
304 = hsep [ptext SLIT("When checking that"), ppr sty main_name, ptext SLIT("has the required type")]
306 noMainErr mod_name main_name sty
307 = hsep [ptext SLIT("Module"), pprModule sty mod_name,
308 ptext SLIT("must include a definition for"), ppr sty main_name]
310 mainTyMisMatch :: Name -> Type -> TcType s -> Error
311 mainTyMisMatch main_name expected actual sty
312 = hang (hsep [ppr sty main_name, ptext SLIT("has the wrong type")])
314 hsep [ptext SLIT("Expected:"), ppr sty expected],
315 hsep [ptext SLIT("Inferred:"), ppr sty actual]