2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcModule]{Typechecking a whole module}
7 #include "HsVersions.h"
12 SYN_IE(TcResultBinds),
13 SYN_IE(TcSpecialiseRequests),
19 import HsSyn ( HsDecl(..), HsModule(..), HsBinds(..), HsExpr, MonoBinds,
20 TyDecl, SpecDataSig, ClassDecl, InstDecl, IfaceSig,
21 SpecInstSig, DefaultDecl, Sig, Fake, InPat,
22 SYN_IE(RecFlag), nonRecursive,
23 FixityDecl, IE, ImportDecl
25 import RnHsSyn ( SYN_IE(RenamedHsModule), RenamedFixityDecl(..) )
26 import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
27 SYN_IE(TypecheckedDictBinds),
28 TcIdOcc(..), zonkBinds )
31 import Inst ( Inst, 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), classGlobalIds )
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 -- Convenient type synonyms first:
86 Bag InstInfo, -- Instance declaration information
91 = (TypecheckedHsBinds, -- record selector binds
92 TypecheckedHsBinds, -- binds from class decls; does NOT
93 -- include default-methods bindings
94 TypecheckedHsBinds, -- binds from instance decls; INCLUDES
95 -- class default-methods binds
96 TypecheckedHsBinds, -- binds from value decls
98 TypecheckedHsBinds) -- constant instance binds
100 type TcSpecialiseRequests
101 = FiniteMap TyCon [(Bool, [Maybe Type])]
102 -- source tycon specialisation requests
113 (TcResults, -- if all goes well...
114 Bag Warning) -- (we can still get warnings)
115 (Bag Error, -- if we had errors...
118 typecheckModule us rn_name_supply mod
119 = initTc us (tcModule rn_name_supply mod)
122 The internal monster:
124 tcModule :: RnNameSupply -- for renaming derivings
125 -> RenamedHsModule -- input
126 -> TcM s TcResults -- output
128 tcModule rn_name_supply
129 (HsModule mod_name verion exports imports fixities decls src_loc)
130 = tcAddSrcLoc src_loc $ -- record where we're starting
132 -- Tie the knot for inteface-file value declaration signatures
133 -- This info is only used inside the knot for type-checking the
134 -- pragmas, which is done lazily [ie failure just drops the pragma
135 -- without having any global-failure effect].
139 fixTc (\ ~(_, _, _, _, _, _, sig_ids) ->
142 tcExtendGlobalValEnv sig_ids (
144 -- The knot for instance information. This isn't used at all
145 -- till we type-check value declarations
146 fixTc ( \ ~(rec_inst_mapper, _, _, _, _) ->
148 -- Type-check the type and class decls
149 -- trace "tcTyAndClassDecls:" $
150 tcTyAndClassDecls1 rec_inst_mapper decls `thenTc` \ env ->
153 -- Typecheck the instance decls, includes deriving
155 -- trace "tcInstDecls:" $
156 tcInstDecls1 decls mod_name rn_name_supply
157 ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
160 buildInstanceEnvs inst_info `thenTc` \ inst_mapper ->
162 returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
164 ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
169 -- Default declarations
170 tcDefaults decls `thenTc` \ defaulting_tys ->
171 tcSetDefaultTys defaulting_tys ( -- for the iface sigs...
173 -- Create any necessary record selector Ids and their bindings
174 -- "Necessary" includes data and newtype declarations
176 tycons = getEnv_TyCons env
177 classes = getEnv_Classes env
179 mkDataBinds tycons `thenTc` \ (data_ids, data_binds) ->
181 -- Extend the global value environment with
183 -- b) record selectors
184 -- c) class op selectors
185 -- d) default-method ids
186 tcExtendGlobalValEnv data_ids $
187 tcExtendGlobalValEnv (concat (map classGlobalIds classes)) $
189 -- Interface type signatures
190 -- We tie a knot so that the Ids read out of interfaces are in scope
191 -- when we read their pragmas.
192 -- What we rely on is that pragmas are typechecked lazily; if
193 -- any type errors are found (ie there's an inconsistency)
194 -- we silently discard the pragma
195 tcInterfaceSigs decls `thenTc` \ sig_ids ->
196 tcGetEnv `thenNF_Tc` \ env ->
199 returnTc (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
201 )))) `thenTc` \ (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, _) ->
204 tcSetEnv env ( -- to the end...
205 tcSetDefaultTys defaulting_tys ( -- ditto
207 -- Value declarations next.
208 -- We also typecheck any extra binds that came out of the "deriving" process
209 -- trace "tcBinds:" $
211 (\ binds1 (binds2, thing) -> (binds1 `ThenBinds` binds2, thing))
212 (get_val_decls decls `ThenBinds` deriv_binds)
213 ( -- Second pass over instance declarations,
214 -- to compile the bindings themselves.
216 tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
217 tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
218 tcCheckMainSig mod_name `thenTc_`
219 tcGetEnv `thenNF_Tc` \ env ->
220 returnTc ( (EmptyBinds, (inst_binds, cls_binds, env)),
221 lie_instdecls `plusLIE` lie_clasdecls
225 `thenTc` \ ((val_binds, (inst_binds, cls_binds, final_env)), lie_alldecls) ->
227 -- Deal with constant or ambiguous InstIds. How could
228 -- there be ambiguous ones? They can only arise if a
229 -- top-level decl falls under the monomorphism
230 -- restriction, and no subsequent decl instantiates its
231 -- type. (Usually, ambiguous type variables are resolved
232 -- during the generalisation step.)
234 tcSimplifyTop lie_alldecls `thenTc` \ const_insts ->
237 -- Backsubstitution. Monomorphic top-level decls may have
238 -- been instantiated by subsequent decls, and the final
239 -- simplification step may have instantiated some
240 -- ambiguous types. So, sadly, we need to back-substitute
241 -- over the whole bunch of bindings.
243 -- More horrible still, we have to do it in a careful order, so that
244 -- all the TcIds are in scope when we come across them.
246 -- These bindings ought really to be bundled together in a huge
247 -- recursive group, but HsSyn doesn't have recursion among Binds, only
248 -- among MonoBinds. Sigh again.
249 zonkBinds nullTyVarEnv nullIdEnv (MonoBind const_insts [] nonRecursive)
250 `thenNF_Tc` \ (const_insts', ve1) ->
251 zonkBinds nullTyVarEnv ve1 val_binds `thenNF_Tc` \ (val_binds', ve2) ->
253 zonkBinds nullTyVarEnv ve2 data_binds `thenNF_Tc` \ (data_binds', _) ->
254 zonkBinds nullTyVarEnv ve2 inst_binds `thenNF_Tc` \ (inst_binds', _) ->
255 zonkBinds nullTyVarEnv ve2 cls_binds `thenNF_Tc` \ (cls_binds', _) ->
258 localids = getEnv_LocalIds final_env
259 tycons = getEnv_TyCons final_env
260 classes = getEnv_Classes final_env
262 local_tycons = filter isLocallyDefined tycons
263 local_classes = filter isLocallyDefined classes
267 (data_binds', cls_binds', inst_binds', val_binds', const_insts'),
269 local_tycons, local_classes, inst_info, tycon_specs,
274 get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
279 tcCheckMainSig mod_name
280 | not is_main && not is_ghc_main
281 = returnTc () -- A non-main module
284 = -- Check that main is defined
285 tcLookupTyCon tycon_name `thenTc` \ (_,_,tycon) ->
286 tcLookupLocalValue main_name `thenNF_Tc` \ maybe_main_id ->
287 case maybe_main_id of {
288 Nothing -> failTc (noMainErr mod_name main_name);
291 -- Check that it has the right type (or a more general one)
293 expected_ty | isSynTyCon tycon = mkSynTy tycon [unitTy]
294 | otherwise = applyTyCon tycon [unitTy]
295 -- This is bizarre. There ought to be a suitable function in Type.lhs!
297 tcInstType [] expected_ty `thenNF_Tc` \ expected_tau ->
298 tcId main_name `thenNF_Tc` \ (_, lie, main_tau) ->
299 tcSetErrCtxt (mainTyCheckCtxt main_name) $
300 unifyTauTy expected_tau
302 checkTc (isEmptyBag lie) (mainTyMisMatch main_name expected_ty (idType main_id))
305 is_main = mod_name == mAIN
306 is_ghc_main = mod_name == gHC_MAIN
308 main_name | is_main = main_NAME
309 | otherwise = mainPrimIO_NAME
311 tycon_name | is_main = ioTyCon_NAME
312 | otherwise = primIoTyCon_NAME
314 mainTyCheckCtxt main_name sty
315 = hsep [ptext SLIT("When checking that"), ppr sty main_name, ptext SLIT("has the required type")]
317 noMainErr mod_name main_name sty
318 = hsep [ptext SLIT("Module"), pprModule sty mod_name,
319 ptext SLIT("must include a definition for"), ppr sty main_name]
321 mainTyMisMatch :: Name -> Type -> TcType s -> Error
322 mainTyMisMatch main_name expected actual sty
323 = hang (hsep [ppr sty main_name, ptext SLIT("has the wrong type")])
325 hsep [ptext SLIT("Expected:"), ppr sty expected],
326 hsep [ptext SLIT("Inferred:"), ppr sty actual]