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 PprStyle ( PprStyle )
62 import TysWiredIn ( unitTy )
63 import PrelMods ( gHC_MAIN, mAIN )
64 import PrelInfo ( main_NAME, mainPrimIO_NAME, ioTyCon_NAME, primIoTyCon_NAME )
65 import TyVar ( GenTyVar, SYN_IE(TyVarEnv), nullTyVarEnv )
66 import Unify ( unifyTauTy )
67 import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
69 import Unique ( Unique )
70 import UniqSupply ( UniqSupply )
72 import Bag ( Bag, isEmptyBag )
74 import FiniteMap ( emptyFM, FiniteMap )
76 #if __GLASGOW_HASKELL__ >= 202
83 Outside-world interface:
85 -- Convenient type synonyms first:
89 Bag InstInfo, -- Instance declaration information
94 = (TypecheckedHsBinds, -- record selector binds
95 TypecheckedHsBinds, -- binds from class decls; does NOT
96 -- include default-methods bindings
97 TypecheckedHsBinds, -- binds from instance decls; INCLUDES
98 -- class default-methods binds
99 TypecheckedHsBinds, -- binds from value decls
101 TypecheckedHsBinds) -- constant instance binds
103 type TcSpecialiseRequests
104 = FiniteMap TyCon [(Bool, [Maybe Type])]
105 -- source tycon specialisation requests
116 (TcResults, -- if all goes well...
117 Bag Warning) -- (we can still get warnings)
118 (Bag Error, -- if we had errors...
121 typecheckModule us rn_name_supply mod
122 = initTc us (tcModule rn_name_supply mod)
125 The internal monster:
127 tcModule :: RnNameSupply -- for renaming derivings
128 -> RenamedHsModule -- input
129 -> TcM s TcResults -- output
131 tcModule rn_name_supply
132 (HsModule mod_name verion exports imports fixities decls src_loc)
133 = tcAddSrcLoc src_loc $ -- record where we're starting
135 -- Tie the knot for inteface-file value declaration signatures
136 -- This info is only used inside the knot for type-checking the
137 -- pragmas, which is done lazily [ie failure just drops the pragma
138 -- without having any global-failure effect].
142 fixTc (\ ~(_, _, _, _, _, _, sig_ids) ->
145 tcExtendGlobalValEnv sig_ids (
147 -- The knot for instance information. This isn't used at all
148 -- till we type-check value declarations
149 fixTc ( \ ~(rec_inst_mapper, _, _, _, _) ->
151 -- Type-check the type and class decls
152 -- trace "tcTyAndClassDecls:" $
153 tcTyAndClassDecls1 rec_inst_mapper decls `thenTc` \ env ->
156 -- Typecheck the instance decls, includes deriving
158 -- trace "tcInstDecls:" $
159 tcInstDecls1 decls mod_name rn_name_supply
160 ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
163 buildInstanceEnvs inst_info `thenTc` \ inst_mapper ->
165 returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
167 ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
172 -- Default declarations
173 tcDefaults decls `thenTc` \ defaulting_tys ->
174 tcSetDefaultTys defaulting_tys ( -- for the iface sigs...
176 -- Create any necessary record selector Ids and their bindings
177 -- "Necessary" includes data and newtype declarations
179 tycons = getEnv_TyCons env
180 classes = getEnv_Classes env
182 mkDataBinds tycons `thenTc` \ (data_ids, data_binds) ->
184 -- Extend the global value environment with
186 -- b) record selectors
187 -- c) class op selectors
188 -- d) default-method ids
189 tcExtendGlobalValEnv data_ids $
190 tcExtendGlobalValEnv (concat (map classGlobalIds classes)) $
192 -- Interface type signatures
193 -- We tie a knot so that the Ids read out of interfaces are in scope
194 -- when we read their pragmas.
195 -- What we rely on is that pragmas are typechecked lazily; if
196 -- any type errors are found (ie there's an inconsistency)
197 -- we silently discard the pragma
198 tcInterfaceSigs decls `thenTc` \ sig_ids ->
199 tcGetEnv `thenNF_Tc` \ env ->
202 returnTc (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
204 )))) `thenTc` \ (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, _) ->
207 tcSetEnv env ( -- to the end...
208 tcSetDefaultTys defaulting_tys ( -- ditto
210 -- Value declarations next.
211 -- We also typecheck any extra binds that came out of the "deriving" process
212 -- trace "tcBinds:" $
214 (\ binds1 (binds2, thing) -> (binds1 `ThenBinds` binds2, thing))
215 (get_val_decls decls `ThenBinds` deriv_binds)
216 ( -- Second pass over instance declarations,
217 -- to compile the bindings themselves.
219 tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
220 tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
221 tcCheckMainSig mod_name `thenTc_`
222 tcGetEnv `thenNF_Tc` \ env ->
223 returnTc ( (EmptyBinds, (inst_binds, cls_binds, env)),
224 lie_instdecls `plusLIE` lie_clasdecls
228 `thenTc` \ ((val_binds, (inst_binds, cls_binds, final_env)), lie_alldecls) ->
230 -- Deal with constant or ambiguous InstIds. How could
231 -- there be ambiguous ones? They can only arise if a
232 -- top-level decl falls under the monomorphism
233 -- restriction, and no subsequent decl instantiates its
234 -- type. (Usually, ambiguous type variables are resolved
235 -- during the generalisation step.)
237 tcSimplifyTop lie_alldecls `thenTc` \ const_insts ->
240 -- Backsubstitution. Monomorphic top-level decls may have
241 -- been instantiated by subsequent decls, and the final
242 -- simplification step may have instantiated some
243 -- ambiguous types. So, sadly, we need to back-substitute
244 -- over the whole bunch of bindings.
246 -- More horrible still, we have to do it in a careful order, so that
247 -- all the TcIds are in scope when we come across them.
249 -- These bindings ought really to be bundled together in a huge
250 -- recursive group, but HsSyn doesn't have recursion among Binds, only
251 -- among MonoBinds. Sigh again.
252 zonkBinds nullTyVarEnv nullIdEnv (MonoBind const_insts [] nonRecursive)
253 `thenNF_Tc` \ (const_insts', ve1) ->
254 zonkBinds nullTyVarEnv ve1 val_binds `thenNF_Tc` \ (val_binds', ve2) ->
256 zonkBinds nullTyVarEnv ve2 data_binds `thenNF_Tc` \ (data_binds', _) ->
257 zonkBinds nullTyVarEnv ve2 inst_binds `thenNF_Tc` \ (inst_binds', _) ->
258 zonkBinds nullTyVarEnv ve2 cls_binds `thenNF_Tc` \ (cls_binds', _) ->
261 localids = getEnv_LocalIds final_env
262 tycons = getEnv_TyCons final_env
263 classes = getEnv_Classes final_env
265 local_tycons = filter isLocallyDefined tycons
266 local_classes = filter isLocallyDefined classes
270 (data_binds', cls_binds', inst_binds', val_binds', const_insts'),
272 local_tycons, local_classes, inst_info, tycon_specs,
277 get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
282 tcCheckMainSig mod_name
283 | not is_main && not is_ghc_main
284 = returnTc () -- A non-main module
287 = -- Check that main is defined
288 tcLookupTyCon tycon_name `thenTc` \ (_,_,tycon) ->
289 tcLookupLocalValue main_name `thenNF_Tc` \ maybe_main_id ->
290 case maybe_main_id of {
291 Nothing -> failTc (noMainErr mod_name main_name);
294 -- Check that it has the right type (or a more general one)
296 expected_ty | isSynTyCon tycon = mkSynTy tycon [unitTy]
297 | otherwise = applyTyCon tycon [unitTy]
298 -- This is bizarre. There ought to be a suitable function in Type.lhs!
300 tcInstType [] expected_ty `thenNF_Tc` \ expected_tau ->
301 tcId main_name `thenNF_Tc` \ (_, lie, main_tau) ->
302 tcSetErrCtxt (mainTyCheckCtxt main_name) $
303 unifyTauTy expected_tau
305 checkTc (isEmptyBag lie) (mainTyMisMatch main_name expected_ty (idType main_id))
308 is_main = mod_name == mAIN
309 is_ghc_main = mod_name == gHC_MAIN
311 main_name | is_main = main_NAME
312 | otherwise = mainPrimIO_NAME
314 tycon_name | is_main = ioTyCon_NAME
315 | otherwise = primIoTyCon_NAME
317 mainTyCheckCtxt main_name sty
318 = hsep [ptext SLIT("When checking that"), ppr sty main_name, ptext SLIT("has the required type")]
320 noMainErr mod_name main_name sty
321 = hsep [ptext SLIT("Module"), pprModule sty mod_name,
322 ptext SLIT("must include a definition for"), ppr sty main_name]
324 mainTyMisMatch :: Name -> Type -> TcType s -> Error
325 mainTyMisMatch main_name expected actual sty
326 = hang (hsep [ppr sty main_name, ptext SLIT("has the wrong type")])
328 hsep [ptext SLIT("Expected:"), ppr sty expected],
329 hsep [ptext SLIT("Inferred:"), ppr sty actual]