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 )
51 import PrelInfo ( unitTy, mkPrimIoTy )
53 import RnUtils ( RnEnv(..) )
54 import TyCon ( TyCon )
55 import Type ( mkSynTy )
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 ->
189 returnTc (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
191 )))) `thenTc` \ (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, _) ->
193 tcSetEnv env ( -- to the end...
194 tcSetDefaultTys defaulting_tys ( -- ditto
196 -- Value declarations next.
197 -- We also typecheck any extra binds that came out of the "deriving" process
200 (\ binds1 (binds2, thing) -> (binds1 `ThenBinds` binds2, thing))
201 (val_decls `ThenBinds` deriv_binds)
202 ( -- Second pass over instance declarations,
203 -- to compile the bindings themselves.
204 tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
205 tcClassDecls2 cls_decls_bag `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
206 tcGetEnv `thenNF_Tc` \ env ->
207 returnTc ( (EmptyBinds, (inst_binds, cls_binds, env)),
208 lie_instdecls `plusLIE` lie_clasdecls,
211 `thenTc` \ ((val_binds, (inst_binds, cls_binds, final_env)), lie_alldecls, _) ->
213 checkTopLevelIds mod_name final_env `thenTc_`
215 -- Deal with constant or ambiguous InstIds. How could
216 -- there be ambiguous ones? They can only arise if a
217 -- top-level decl falls under the monomorphism
218 -- restriction, and no subsequent decl instantiates its
219 -- type. (Usually, ambiguous type variables are resolved
220 -- during the generalisation step.)
221 tcSimplifyTop lie_alldecls `thenTc` \ const_insts ->
223 -- Backsubstitution. Monomorphic top-level decls may have
224 -- been instantiated by subsequent decls, and the final
225 -- simplification step may have instantiated some
226 -- ambiguous types. So, sadly, we need to back-substitute
227 -- over the whole bunch of bindings.
229 -- More horrible still, we have to do it in a careful order, so that
230 -- all the TcIds are in scope when we come across them.
232 -- These bindings ought really to be bundled together in a huge
233 -- recursive group, but HsSyn doesn't have recursion among Binds, only
234 -- among MonoBinds. Sigh again.
235 zonkDictBinds nullTyVarEnv nullIdEnv const_insts `thenNF_Tc` \ (const_insts', ve1) ->
236 zonkBinds nullTyVarEnv ve1 val_binds `thenNF_Tc` \ (val_binds', ve2) ->
238 zonkBinds nullTyVarEnv ve2 data_binds `thenNF_Tc` \ (data_binds', _) ->
239 zonkBinds nullTyVarEnv ve2 inst_binds `thenNF_Tc` \ (inst_binds', _) ->
240 zonkBinds nullTyVarEnv ve2 cls_binds `thenNF_Tc` \ (cls_binds', _) ->
243 localids = getEnv_LocalIds final_env
244 tycons = getEnv_TyCons final_env
245 classes = getEnv_Classes final_env
247 local_tycons = filter isLocallyDefined tycons
248 local_classes = filter isLocallyDefined classes
249 exported_ids' = filter isExported (eltsUFM ve2)
254 (data_binds', cls_binds', inst_binds', val_binds', const_insts'),
256 -- the next collection is just for mkInterface
257 (exported_ids', tycons, classes, inst_info),
259 (local_tycons, local_classes),
266 ty_decls_bag = listToBag ty_decls
267 cls_decls_bag = listToBag cls_decls
268 inst_decls_bag = listToBag inst_decls
273 %************************************************************************
275 \subsection{Error checking code}
277 %************************************************************************
280 checkTopLevelIds checks that Main.main or Main.mainPrimIO has correct type.
283 checkTopLevelIds :: FAST_STRING -> TcEnv s -> TcM s ()
284 checkTopLevelIds mod final_env
285 | mod /= SLIT("Main")
289 = tcSetEnv final_env (
290 tcLookupLocalValueByKey mainIdKey `thenNF_Tc` \ maybe_main ->
291 tcLookupLocalValueByKey mainPrimIOIdKey `thenNF_Tc` \ maybe_prim ->
292 tcLookupTyConByKey iOTyConKey `thenNF_Tc` \ io_tc ->
294 case (maybe_main, maybe_prim) of
295 (Just main, Nothing) -> tcAddErrCtxt mainCtxt $
296 unifyTauTy (mkSynTy io_tc [unitTy])
299 (Nothing, Just prim) -> tcAddErrCtxt primCtxt $
300 unifyTauTy (mkPrimIoTy unitTy)
303 (Just _ , Just _ ) -> failTc mainBothIdErr
304 (Nothing, Nothing) -> failTc mainNoneIdErr
308 = ppStr "main should have type IO ()"
311 = ppStr "mainPrimIO should have type PrimIO ()"
314 = ppStr "module Main contains definitions for both main and mainPrimIO"
317 = ppStr "module Main does not contain a definition for main (or mainPrimIO)"