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(..), Bind, HsExpr,
20 TyDecl, SpecDataSig, ClassDecl, InstDecl, IfaceSig,
21 SpecInstSig, DefaultDecl, Sig, Fake, InPat,
22 FixityDecl, IE, ImportDecl
24 import RnHsSyn ( SYN_IE(RenamedHsModule), RenamedFixityDecl(..) )
25 import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
26 TcIdOcc(..), zonkBinds, zonkDictBinds )
29 import Inst ( Inst, plusLIE )
30 import TcBinds ( tcBindsAndThen )
31 import TcClassDcl ( tcClassDecls2 )
32 import TcDefaults ( tcDefaults )
33 import TcEnv ( tcExtendGlobalValEnv, getEnv_LocalIds,
34 getEnv_TyCons, getEnv_Classes,
35 tcLookupLocalValueByKey, tcLookupTyConByKey )
36 import SpecEnv ( SpecEnv )
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 RnMonad ( RnNameSupply(..) )
45 import Bag ( listToBag )
46 import Class ( GenClass, classSelIds )
47 import ErrUtils ( SYN_IE(Warning), SYN_IE(Error) )
48 import Id ( idType, GenId, SYN_IE(IdEnv), nullIdEnv )
49 import Maybes ( catMaybes )
50 import Name ( isLocallyDefined )
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 )
62 import FiniteMap ( emptyFM, FiniteMap )
66 Outside-world interface:
68 -- Convenient type synonyms first:
72 Bag InstInfo, -- Instance declaration information
77 = (TypecheckedHsBinds, -- record selector binds
78 TypecheckedHsBinds, -- binds from class decls; does NOT
79 -- include default-methods bindings
80 TypecheckedHsBinds, -- binds from instance decls; INCLUDES
81 -- class default-methods binds
82 TypecheckedHsBinds, -- binds from value decls
84 [(Id, TypecheckedHsExpr)]) -- constant instance binds
86 type TcSpecialiseRequests
87 = FiniteMap TyCon [(Bool, [Maybe Type])]
88 -- source tycon specialisation requests
99 (TcResults, -- if all goes well...
100 Bag Warning) -- (we can still get warnings)
101 (Bag Error, -- if we had errors...
104 typecheckModule us rn_name_supply mod
105 = initTc us (tcModule rn_name_supply mod)
108 The internal monster:
110 tcModule :: RnNameSupply -- for renaming derivings
111 -> RenamedHsModule -- input
112 -> TcM s TcResults -- output
114 tcModule rn_name_supply
115 (HsModule mod_name verion exports imports fixities decls src_loc)
116 = tcAddSrcLoc src_loc $ -- record where we're starting
118 -- Tie the knot for inteface-file value declaration signatures
119 -- This info is only used inside the knot for type-checking the
120 -- pragmas, which is done lazily [ie failure just drops the pragma
121 -- without having any global-failure effect].
125 fixTc (\ ~(_, _, _, _, _, _, sig_ids) ->
128 tcExtendGlobalValEnv sig_ids (
130 -- The knot for instance information. This isn't used at all
131 -- till we type-check value declarations
132 fixTc ( \ ~(rec_inst_mapper, _, _, _, _) ->
134 -- Type-check the type and class decls
135 -- trace "tcTyAndClassDecls:" $
136 tcTyAndClassDecls1 rec_inst_mapper decls `thenTc` \ env ->
139 -- Typecheck the instance decls, includes deriving
141 -- trace "tcInstDecls:" $
142 tcInstDecls1 decls mod_name rn_name_supply
143 ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
146 buildInstanceEnvs inst_info `thenTc` \ inst_mapper ->
148 returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
150 ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
155 -- Default declarations
156 tcDefaults decls `thenTc` \ defaulting_tys ->
157 tcSetDefaultTys defaulting_tys ( -- for the iface sigs...
159 -- Create any necessary record selector Ids and their bindings
160 -- "Necessary" includes data and newtype declarations
162 tycons = getEnv_TyCons env
163 classes = getEnv_Classes env
165 mkDataBinds tycons `thenTc` \ (data_ids, data_binds) ->
167 -- Extend the global value environment with
169 -- b) record selectors
170 -- c) class op selectors
171 tcExtendGlobalValEnv data_ids $
172 tcExtendGlobalValEnv (concat (map classSelIds classes)) $
174 -- Interface type signatures
175 -- We tie a knot so that the Ids read out of interfaces are in scope
176 -- when we read their pragmas.
177 -- What we rely on is that pragmas are typechecked lazily; if
178 -- any type errors are found (ie there's an inconsistency)
179 -- we silently discard the pragma
180 tcInterfaceSigs decls `thenTc` \ sig_ids ->
181 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, _) ->
189 tcSetEnv env ( -- to the end...
190 tcSetDefaultTys defaulting_tys ( -- ditto
192 -- Value declarations next.
193 -- We also typecheck any extra binds that came out of the "deriving" process
194 -- trace "tcBinds:" $
196 (\ binds1 (binds2, thing) -> (binds1 `ThenBinds` binds2, thing))
197 (get_val_decls decls `ThenBinds` deriv_binds)
198 ( -- Second pass over instance declarations,
199 -- to compile the bindings themselves.
201 tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
202 tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
203 tcGetEnv `thenNF_Tc` \ env ->
204 returnTc ( (EmptyBinds, (inst_binds, cls_binds, env)),
205 lie_instdecls `plusLIE` lie_clasdecls,
208 `thenTc` \ ((val_binds, (inst_binds, cls_binds, final_env)), lie_alldecls, _) ->
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.)
217 tcSimplifyTop lie_alldecls `thenTc` \ const_insts ->
219 -- Backsubstitution. Monomorphic top-level decls may have
220 -- been instantiated by subsequent decls, and the final
221 -- simplification step may have instantiated some
222 -- ambiguous types. So, sadly, we need to back-substitute
223 -- over the whole bunch of bindings.
225 -- More horrible still, we have to do it in a careful order, so that
226 -- all the TcIds are in scope when we come across them.
228 -- These bindings ought really to be bundled together in a huge
229 -- recursive group, but HsSyn doesn't have recursion among Binds, only
230 -- among MonoBinds. Sigh again.
231 zonkDictBinds nullTyVarEnv nullIdEnv const_insts `thenNF_Tc` \ (const_insts', ve1) ->
232 zonkBinds nullTyVarEnv ve1 val_binds `thenNF_Tc` \ (val_binds', ve2) ->
234 zonkBinds nullTyVarEnv ve2 data_binds `thenNF_Tc` \ (data_binds', _) ->
235 zonkBinds nullTyVarEnv ve2 inst_binds `thenNF_Tc` \ (inst_binds', _) ->
236 zonkBinds nullTyVarEnv ve2 cls_binds `thenNF_Tc` \ (cls_binds', _) ->
239 localids = getEnv_LocalIds final_env
240 tycons = getEnv_TyCons final_env
241 classes = getEnv_Classes final_env
243 local_tycons = filter isLocallyDefined tycons
244 local_classes = filter isLocallyDefined classes
248 (data_binds', cls_binds', inst_binds', val_binds', const_insts'),
250 local_tycons, inst_info, tycon_specs,
255 get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]