2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcModule]{Typechecking a whole module}
7 #include "HsVersions.h"
14 TcLocalTyConsAndClasses(..),
15 TcSpecialiseRequests(..),
21 import HsSyn ( HsModule(..), HsBinds(..), Bind, HsExpr,
22 TyDecl, SpecDataSig, ClassDecl, InstDecl,
23 SpecInstSig, DefaultDecl, Sig, Fake, InPat,
24 FixityDecl, IE, ImportDecl
26 import RnHsSyn ( RenamedHsModule(..), RenamedFixityDecl(..) )
27 import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
28 TcIdOcc(..), zonkBinds, zonkDictBinds )
30 import TcMonad hiding ( rnMtoTcM )
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,
37 tcLookupLocalValueByKey, tcLookupTyConByKey )
38 import TcIfaceSig ( tcInterfaceSigs )
39 import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
40 import TcInstUtil ( buildInstanceEnvs, InstInfo )
41 import TcSimplify ( tcSimplifyTop )
42 import TcTyClsDecls ( tcTyAndClassDecls1 )
43 import TcTyDecls ( mkDataBinds )
45 import Bag ( listToBag )
46 import Class ( GenClass, classSelIds )
47 import ErrUtils ( Warning(..), Error(..) )
48 import Id ( GenId, isDataCon, isMethodSelId, idType, IdEnv(..), nullIdEnv )
49 import Maybes ( catMaybes )
50 import Name ( isExported, isLocallyDefined )
52 import RnUtils ( RnEnv(..) )
53 import TyCon ( isDataTyCon, TyCon )
54 import Type ( mkSynTy )
55 import TysWiredIn ( unitTy, mkPrimIoTy )
56 import TyVar ( TyVarEnv(..), nullTyVarEnv )
57 import Unify ( unifyTauTy )
58 import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
60 import Unique ( iOTyConKey, mainIdKey, mainPrimIOIdKey )
63 import FiniteMap ( emptyFM )
67 Outside-world interface:
69 -- Convenient type synonyms first:
73 TcLocalTyConsAndClasses,
78 = (TypecheckedHsBinds, -- record selector binds
79 TypecheckedHsBinds, -- binds from class decls; does NOT
80 -- include default-methods bindings
81 TypecheckedHsBinds, -- binds from instance decls; INCLUDES
82 -- class default-methods binds
83 TypecheckedHsBinds, -- binds from value decls
85 [(Id, TypecheckedHsExpr)]) -- constant instance binds
87 type TcIfaceInfo -- things for the interface generator
88 = ([Id], [TyCon], [Class], Bag InstInfo)
90 type TcLocalTyConsAndClasses -- things defined in this module
92 -- not sure the classes are used at all (ToDo)
94 type TcSpecialiseRequests
95 = FiniteMap TyCon [(Bool, [Maybe Type])]
96 -- source tycon specialisation requests
104 -> RnEnv -- for renaming derivings
107 (TcResults, -- if all goes well...
108 Bag Warning) -- (we can still get warnings)
109 (Bag Error, -- if we had errors...
112 typecheckModule us rn_env mod
113 = initTc us (tcModule rn_env mod)
116 The internal monster:
118 tcModule :: RnEnv -- for renaming derivings
119 -> RenamedHsModule -- input
120 -> TcM s TcResults -- output
123 (HsModule mod_name verion exports imports fixities
124 ty_decls specdata_sigs cls_decls inst_decls specinst_sigs
125 default_decls val_decls sigs src_loc)
127 = ASSERT(null imports)
129 tcAddSrcLoc src_loc $ -- record where we're starting
131 -- Tie the knot for inteface-file value declaration signatures
132 -- This info is only used inside the knot for type-checking the
133 -- pragmas, which is done lazily [ie failure just drops the pragma
134 -- without having any global-failure effect].
136 fixTc (\ ~(_, _, _, _, _, _, sig_ids) ->
137 tcExtendGlobalValEnv sig_ids (
139 -- The knot for instance information. This isn't used at all
140 -- till we type-check value declarations
141 fixTc ( \ ~(rec_inst_mapper, _, _, _, _) ->
143 -- Type-check the type and class decls
144 --trace "tcTyAndClassDecls:" $
145 tcTyAndClassDecls1 rec_inst_mapper ty_decls_bag cls_decls_bag
148 -- Typecheck the instance decls, includes deriving
150 --trace "tcInstDecls:" $
151 tcInstDecls1 inst_decls_bag specinst_sigs
152 mod_name rn_env fixities
153 ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
155 buildInstanceEnvs inst_info `thenTc` \ inst_mapper ->
157 returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
159 ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
162 -- Default declarations
163 tcDefaults default_decls `thenTc` \ defaulting_tys ->
164 tcSetDefaultTys defaulting_tys ( -- for the iface sigs...
166 -- Create any necessary record selector Ids and their bindings
167 -- "Necessary" includes data and newtype declarations
169 tycons = getEnv_TyCons env
170 classes = getEnv_Classes env
172 mkDataBinds tycons `thenTc` \ (data_ids, data_binds) ->
174 -- Extend the global value environment with
176 -- b) record selectors
177 -- c) class op selectors
178 tcExtendGlobalValEnv data_ids $
179 tcExtendGlobalValEnv (concat (map classSelIds classes)) $
181 -- Interface type signatures
182 -- We tie a knot so that the Ids read out of interfaces are in scope
183 -- when we read their pragmas.
184 -- What we rely on is that pragmas are typechecked lazily; if
185 -- any type errors are found (ie there's an inconsistency)
186 -- we silently discard the pragma
187 tcInterfaceSigs sigs `thenTc` \ sig_ids ->
188 tcGetEnv `thenNF_Tc` \ env ->
190 returnTc (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
192 )))) `thenTc` \ (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, _) ->
194 tcSetEnv env ( -- to the end...
195 tcSetDefaultTys defaulting_tys ( -- ditto
197 -- Value declarations next.
198 -- We also typecheck any extra binds that came out of the "deriving" process
201 (\ binds1 (binds2, thing) -> (binds1 `ThenBinds` binds2, thing))
202 (val_decls `ThenBinds` deriv_binds)
203 ( -- Second pass over instance declarations,
204 -- to compile the bindings themselves.
205 tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
206 tcClassDecls2 cls_decls_bag `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
207 tcGetEnv `thenNF_Tc` \ env ->
208 returnTc ( (EmptyBinds, (inst_binds, cls_binds, env)),
209 lie_instdecls `plusLIE` lie_clasdecls,
212 `thenTc` \ ((val_binds, (inst_binds, cls_binds, final_env)), lie_alldecls, _) ->
214 checkTopLevelIds mod_name final_env `thenTc_`
216 -- Deal with constant or ambiguous InstIds. How could
217 -- there be ambiguous ones? They can only arise if a
218 -- top-level decl falls under the monomorphism
219 -- restriction, and no subsequent decl instantiates its
220 -- type. (Usually, ambiguous type variables are resolved
221 -- during the generalisation step.)
222 tcSimplifyTop lie_alldecls `thenTc` \ const_insts ->
224 -- Backsubstitution. Monomorphic top-level decls may have
225 -- been instantiated by subsequent decls, and the final
226 -- simplification step may have instantiated some
227 -- ambiguous types. So, sadly, we need to back-substitute
228 -- over the whole bunch of bindings.
230 -- More horrible still, we have to do it in a careful order, so that
231 -- all the TcIds are in scope when we come across them.
233 -- These bindings ought really to be bundled together in a huge
234 -- recursive group, but HsSyn doesn't have recursion among Binds, only
235 -- among MonoBinds. Sigh again.
236 zonkDictBinds nullTyVarEnv nullIdEnv const_insts `thenNF_Tc` \ (const_insts', ve1) ->
237 zonkBinds nullTyVarEnv ve1 val_binds `thenNF_Tc` \ (val_binds', ve2) ->
239 zonkBinds nullTyVarEnv ve2 data_binds `thenNF_Tc` \ (data_binds', _) ->
240 zonkBinds nullTyVarEnv ve2 inst_binds `thenNF_Tc` \ (inst_binds', _) ->
241 zonkBinds nullTyVarEnv ve2 cls_binds `thenNF_Tc` \ (cls_binds', _) ->
244 localids = getEnv_LocalIds final_env
245 tycons = getEnv_TyCons final_env
246 classes = getEnv_Classes final_env
248 local_tycons = [ tc | tc <- tycons, isLocallyDefined tc && isDataTyCon tc ]
249 local_classes = filter isLocallyDefined classes
250 exported_ids' = filter isExported (eltsUFM ve2)
255 (data_binds', cls_binds', inst_binds', val_binds', const_insts'),
257 -- the next collection is just for mkInterface
258 (exported_ids', tycons, classes, inst_info),
260 (local_tycons, local_classes),
267 ty_decls_bag = listToBag ty_decls
268 cls_decls_bag = listToBag cls_decls
269 inst_decls_bag = listToBag inst_decls
274 %************************************************************************
276 \subsection{Error checking code}
278 %************************************************************************
281 checkTopLevelIds checks that Main.main or Main.mainPrimIO has correct type.
284 checkTopLevelIds :: FAST_STRING -> TcEnv s -> TcM s ()
285 checkTopLevelIds mod final_env
286 | mod /= SLIT("Main")
290 = tcSetEnv final_env (
291 tcLookupLocalValueByKey mainIdKey `thenNF_Tc` \ maybe_main ->
292 tcLookupLocalValueByKey mainPrimIOIdKey `thenNF_Tc` \ maybe_prim ->
293 tcLookupTyConByKey iOTyConKey `thenNF_Tc` \ io_tc ->
295 case (maybe_main, maybe_prim) of
296 (Just main, Nothing) -> tcAddErrCtxt mainCtxt $
297 unifyTauTy (mkSynTy io_tc [unitTy])
300 (Nothing, Just prim) -> tcAddErrCtxt primCtxt $
301 unifyTauTy (mkPrimIoTy unitTy)
304 (Just _ , Just _ ) -> failTc mainBothIdErr
305 (Nothing, Nothing) -> failTc mainNoneIdErr
309 = ppStr "main should have type IO ()"
312 = ppStr "mainPrimIO should have type PrimIO ()"
315 = ppStr "module Main contains definitions for both main and mainPrimIO"
318 = ppStr "module Main does not contain a definition for main (or mainPrimIO)"