2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcModule]{Typechecking a whole module}
7 #include "HsVersions.h"
14 TcSpecialiseRequests(..),
20 import HsSyn ( HsModule(..), HsBinds(..), Bind, HsExpr,
21 TyDecl, SpecDataSig, ClassDecl, InstDecl,
22 SpecInstSig, DefaultDecl, Sig, Fake, InPat,
23 FixityDecl, IE, ImportDecl
25 import RnHsSyn ( RenamedHsModule(..), RenamedFixityDecl(..) )
26 import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
27 TcIdOcc(..), zonkBinds, zonkDictBinds )
29 import TcMonad hiding ( rnMtoTcM )
30 import Inst ( Inst, plusLIE )
31 import TcBinds ( tcBindsAndThen )
32 import TcClassDcl ( tcClassDecls2 )
33 import TcDefaults ( tcDefaults )
34 import TcEnv ( tcExtendGlobalValEnv, getEnv_LocalIds,
35 getEnv_TyCons, getEnv_Classes,
36 tcLookupLocalValueByKey, tcLookupTyConByKey )
37 import TcIfaceSig ( tcInterfaceSigs )
38 import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
39 import TcInstUtil ( buildInstanceEnvs, InstInfo )
40 import TcSimplify ( tcSimplifyTop )
41 import TcTyClsDecls ( tcTyAndClassDecls1 )
42 import TcTyDecls ( mkDataBinds )
44 import Bag ( listToBag )
45 import Class ( GenClass, classSelIds )
46 import ErrUtils ( SYN_IE(Warning), SYN_IE(Error) )
47 import Id ( idType, isMethodSelId, isTopLevId, GenId, SYN_IE(IdEnv), nullIdEnv )
48 import Maybes ( catMaybes )
49 import Name ( isLocallyDefined )
51 import RnUtils ( SYN_IE(RnEnv) )
52 import TyCon ( TyCon )
53 import Type ( applyTyCon )
54 import TysWiredIn ( unitTy, mkPrimIoTy )
55 import TyVar ( SYN_IE(TyVarEnv), nullTyVarEnv )
56 import Unify ( unifyTauTy )
57 import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
59 import Unique ( iOTyConKey, mainIdKey, mainPrimIOIdKey )
62 import FiniteMap ( emptyFM )
66 Outside-world interface:
68 -- Convenient type synonyms first:
76 = (TypecheckedHsBinds, -- record selector binds
77 TypecheckedHsBinds, -- binds from class decls; does NOT
78 -- include default-methods bindings
79 TypecheckedHsBinds, -- binds from instance decls; INCLUDES
80 -- class default-methods binds
81 TypecheckedHsBinds, -- binds from value decls
83 [(Id, TypecheckedHsExpr)]) -- constant instance binds
85 type TcIfaceInfo -- things for the interface generator
86 = ([Id], [TyCon], [Class], Bag InstInfo)
88 type TcSpecialiseRequests
89 = FiniteMap TyCon [(Bool, [Maybe Type])]
90 -- source tycon specialisation requests
98 -> RnEnv -- for renaming derivings
101 (TcResults, -- if all goes well...
102 Bag Warning) -- (we can still get warnings)
103 (Bag Error, -- if we had errors...
106 typecheckModule us rn_env mod
107 = initTc us (tcModule rn_env mod)
110 The internal monster:
112 tcModule :: RnEnv -- for renaming derivings
113 -> RenamedHsModule -- input
114 -> TcM s TcResults -- output
117 (HsModule mod_name verion exports imports fixities
118 ty_decls specdata_sigs cls_decls inst_decls specinst_sigs
119 default_decls val_decls sigs src_loc)
121 = ASSERT(null imports)
123 tcAddSrcLoc src_loc $ -- record where we're starting
125 -- Tie the knot for inteface-file value declaration signatures
126 -- This info is only used inside the knot for type-checking the
127 -- pragmas, which is done lazily [ie failure just drops the pragma
128 -- without having any global-failure effect].
130 fixTc (\ ~(_, _, _, _, _, _, sig_ids) ->
131 tcExtendGlobalValEnv sig_ids (
133 -- The knot for instance information. This isn't used at all
134 -- till we type-check value declarations
135 fixTc ( \ ~(rec_inst_mapper, _, _, _, _) ->
137 -- Type-check the type and class decls
138 --trace "tcTyAndClassDecls:" $
139 tcTyAndClassDecls1 rec_inst_mapper ty_decls_bag cls_decls_bag
142 -- Typecheck the instance decls, includes deriving
144 --trace "tcInstDecls:" $
145 tcInstDecls1 inst_decls_bag specinst_sigs
146 mod_name rn_env fixities
147 ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
149 buildInstanceEnvs inst_info `thenTc` \ inst_mapper ->
151 returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
153 ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
156 -- Default declarations
157 tcDefaults default_decls `thenTc` \ defaulting_tys ->
158 tcSetDefaultTys defaulting_tys ( -- for the iface sigs...
160 -- Create any necessary record selector Ids and their bindings
161 -- "Necessary" includes data and newtype declarations
163 tycons = getEnv_TyCons env
164 classes = getEnv_Classes env
166 mkDataBinds tycons `thenTc` \ (data_ids, data_binds) ->
168 -- Extend the global value environment with
170 -- b) record selectors
171 -- c) class op selectors
172 tcExtendGlobalValEnv data_ids $
173 tcExtendGlobalValEnv (concat (map classSelIds classes)) $
175 -- Interface type signatures
176 -- We tie a knot so that the Ids read out of interfaces are in scope
177 -- when we read their pragmas.
178 -- What we rely on is that pragmas are typechecked lazily; if
179 -- any type errors are found (ie there's an inconsistency)
180 -- we silently discard the pragma
181 tcInterfaceSigs sigs `thenTc` \ sig_ids ->
182 tcGetEnv `thenNF_Tc` \ env ->
184 returnTc (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
186 )))) `thenTc` \ (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, _) ->
188 tcSetEnv env ( -- to the end...
189 tcSetDefaultTys defaulting_tys ( -- ditto
191 -- Value declarations next.
192 -- We also typecheck any extra binds that came out of the "deriving" process
195 (\ binds1 (binds2, thing) -> (binds1 `ThenBinds` binds2, thing))
196 (val_decls `ThenBinds` deriv_binds)
197 ( -- Second pass over instance declarations,
198 -- to compile the bindings themselves.
199 tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
200 tcClassDecls2 cls_decls_bag `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
201 tcGetEnv `thenNF_Tc` \ env ->
202 returnTc ( (EmptyBinds, (inst_binds, cls_binds, env)),
203 lie_instdecls `plusLIE` lie_clasdecls,
206 `thenTc` \ ((val_binds, (inst_binds, cls_binds, final_env)), lie_alldecls, _) ->
208 checkTopLevelIds mod_name final_env `thenTc_`
210 -- Deal with constant or ambiguous InstIds. How could
211 -- there be ambiguous ones? They can only arise if a
212 -- top-level decl falls under the monomorphism
213 -- restriction, and no subsequent decl instantiates its
214 -- type. (Usually, ambiguous type variables are resolved
215 -- during the generalisation step.)
216 tcSimplifyTop lie_alldecls `thenTc` \ const_insts ->
218 -- Backsubstitution. Monomorphic top-level decls may have
219 -- been instantiated by subsequent decls, and the final
220 -- simplification step may have instantiated some
221 -- ambiguous types. So, sadly, we need to back-substitute
222 -- over the whole bunch of bindings.
224 -- More horrible still, we have to do it in a careful order, so that
225 -- all the TcIds are in scope when we come across them.
227 -- These bindings ought really to be bundled together in a huge
228 -- recursive group, but HsSyn doesn't have recursion among Binds, only
229 -- among MonoBinds. Sigh again.
230 zonkDictBinds nullTyVarEnv nullIdEnv const_insts `thenNF_Tc` \ (const_insts', ve1) ->
231 zonkBinds nullTyVarEnv ve1 val_binds `thenNF_Tc` \ (val_binds', ve2) ->
233 zonkBinds nullTyVarEnv ve2 data_binds `thenNF_Tc` \ (data_binds', _) ->
234 zonkBinds nullTyVarEnv ve2 inst_binds `thenNF_Tc` \ (inst_binds', _) ->
235 zonkBinds nullTyVarEnv ve2 cls_binds `thenNF_Tc` \ (cls_binds', _) ->
238 localids = getEnv_LocalIds final_env
239 tycons = getEnv_TyCons final_env
240 classes = getEnv_Classes final_env
242 local_tycons = filter isLocallyDefined tycons
243 local_classes = filter isLocallyDefined classes
244 local_vals = [ v | v <- eltsUFM ve2, isLocallyDefined v && isTopLevId v ]
245 -- the isTopLevId is doubtful...
249 (data_binds', cls_binds', inst_binds', val_binds', const_insts'),
251 -- the next collection is just for mkInterface
252 (local_vals, local_tycons, local_classes, inst_info),
259 ty_decls_bag = listToBag ty_decls
260 cls_decls_bag = listToBag cls_decls
261 inst_decls_bag = listToBag inst_decls
265 %************************************************************************
267 \subsection{Error checking code}
269 %************************************************************************
272 checkTopLevelIds checks that Main.main or GHCmain.mainPrimIO has correct type.
275 checkTopLevelIds :: FAST_STRING -> TcEnv s -> TcM s ()
277 checkTopLevelIds mod final_env
278 | mod /= SLIT("Main") && mod /= SLIT("GHCmain")
281 | mod == SLIT("Main")
282 = tcSetEnv final_env (
283 tcLookupLocalValueByKey mainIdKey `thenNF_Tc` \ maybe_main ->
284 tcLookupTyConByKey iOTyConKey `thenNF_Tc` \ io_tc ->
287 Just main -> tcAddErrCtxt mainCtxt $
288 unifyTauTy (applyTyCon io_tc [unitTy])
291 Nothing -> failTc (mainNoneIdErr "Main" "main")
294 | mod == SLIT("GHCmain")
295 = tcSetEnv final_env (
296 tcLookupLocalValueByKey mainPrimIOIdKey `thenNF_Tc` \ maybe_prim ->
299 Just prim -> tcAddErrCtxt primCtxt $
300 unifyTauTy (mkPrimIoTy unitTy)
303 Nothing -> failTc (mainNoneIdErr "GHCmain" "mainPrimIO")
307 = ppStr "Main.main should have type IO ()"
310 = ppStr "GHCmain.mainPrimIO should have type PrimIO ()"
312 mainNoneIdErr mod n sty
313 = ppCat [ppPStr SLIT("module"), ppStr mod, ppPStr SLIT("does not contain a definition for"), ppStr n]