2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcModule]{Typechecking a whole module}
7 #include "HsVersions.h"
15 import HsSyn ( HsModule(..), HsBinds(..), Bind, HsExpr,
16 TyDecl, SpecDataSig, ClassDecl, InstDecl,
17 SpecInstSig, DefaultDecl, Sig, Fake, InPat,
18 FixityDecl, IE, ImportedInterface )
19 import RnHsSyn ( RenamedHsModule(..), RenamedFixityDecl(..) )
20 import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
21 TcIdOcc(..), zonkBinds, zonkInst, zonkId )
24 import Inst ( Inst, plusLIE )
25 import TcBinds ( tcBindsAndThen )
26 import TcClassDcl ( tcClassDecls2 )
27 import TcDefaults ( tcDefaults )
28 import TcEnv ( tcExtendGlobalValEnv, getEnv_LocalIds,
29 getEnv_TyCons, getEnv_Classes,
30 tcLookupLocalValueByKey, tcLookupTyConByKey )
31 import TcIfaceSig ( tcInterfaceSigs )
32 import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
33 import TcInstUtil ( buildInstanceEnvs, InstInfo )
34 import TcSimplify ( tcSimplifyTop )
35 import TcTyClsDecls ( tcTyAndClassDecls1 )
37 import Bag ( listToBag )
38 import Class ( GenClass )
39 import Id ( GenId, isDataCon, isMethodSelId, idType )
40 import Maybes ( catMaybes )
41 import Name ( Name(..) )
42 import Outputable ( isExported )
43 import PrelInfo ( unitTy, mkPrimIoTy )
45 import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
46 import TyCon ( TyCon )
47 import Type ( applyTyCon )
48 import Unify ( unifyTauTy )
49 import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
51 import Unique ( iOTyConKey, mainIdKey, mainPrimIOIdKey )
55 import FiniteMap ( emptyFM )
62 tcModule :: GlobalNameMappers -- final renamer info for derivings
63 -> RenamedHsModule -- input
64 -> TcM s ((TypecheckedHsBinds, -- binds from class decls; does NOT
65 -- include default-methods bindings
66 TypecheckedHsBinds, -- binds from instance decls; INCLUDES
67 -- class default-methods binds
68 TypecheckedHsBinds, -- binds from value decls
70 [(Id, TypecheckedHsExpr)]), -- constant instance binds
72 ([RenamedFixityDecl], [Id], [TyCon], [Class], Bag InstInfo),
73 -- things for the interface generator
76 -- environments of info from this module only
78 FiniteMap TyCon [(Bool, [Maybe Type])],
79 -- source tycon specialisation requests
81 PprStyle -> Pretty) -- -ddump-deriving info
83 tcModule renamer_name_funs
84 (HsModule mod_name exports imports fixities
85 ty_decls specdata_sigs cls_decls inst_decls specinst_sigs
86 default_decls val_decls sigs src_loc)
88 = ASSERT(null imports)
90 tcAddSrcLoc src_loc $ -- record where we're starting
92 -- Tie the knot for inteface-file value declaration signatures
93 -- This info is only used inside the knot for type-checking the
94 -- pragmas, which is done lazily [ie failure just drops the pragma
95 -- without having any global-failure effect].
97 fixTc (\ ~(_, _, _, _, _, sig_ids) ->
98 tcExtendGlobalValEnv sig_ids (
100 -- The knot for instance information. This isn't used at all
101 -- till we type-check value declarations
102 fixTc ( \ ~(rec_inst_mapper, _, _, _, _) ->
104 -- Type-check the type and class decls
105 trace "tcTyAndClassDecls:" $
106 tcTyAndClassDecls1 rec_inst_mapper ty_decls_bag cls_decls_bag
109 -- Typecheck the instance decls, includes deriving
111 trace "tcInstDecls:" $
112 tcInstDecls1 inst_decls_bag specinst_sigs
113 mod_name renamer_name_funs fixities
114 ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
116 buildInstanceEnvs inst_info `thenTc` \ inst_mapper ->
118 returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
120 ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
123 -- Default declarations
124 tcDefaults default_decls `thenTc` \ defaulting_tys ->
125 tcSetDefaultTys defaulting_tys ( -- for the iface sigs...
127 -- Interface type signatures
128 -- We tie a knot so that the Ids read out of interfaces are in scope
129 -- when we read their pragmas.
130 -- What we rely on is that pragmas are typechecked lazily; if
131 -- any type errors are found (ie there's an inconsistency)
132 -- we silently discard the pragma
133 tcInterfaceSigs sigs `thenTc` \ sig_ids ->
135 returnTc (env, inst_info, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
137 )))) `thenTc` \ (env, inst_info, deriv_binds, ddump_deriv, defaulting_tys, _) ->
139 tcSetEnv env ( -- to the end...
140 tcSetDefaultTys defaulting_tys ( -- ditto
142 -- Value declarations next.
143 -- We also typecheck any extra binds that came out of the "deriving" process
146 (\ binds1 (binds2, thing) -> (binds1 `ThenBinds` binds2, thing))
147 (val_decls `ThenBinds` deriv_binds)
148 ( -- Second pass over instance declarations,
149 -- to compile the bindings themselves.
150 tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
151 tcClassDecls2 cls_decls_bag `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
152 tcGetEnv `thenNF_Tc` \ env ->
153 returnTc ( (EmptyBinds, (inst_binds, cls_binds, env)),
154 lie_instdecls `plusLIE` lie_clasdecls,
157 `thenTc` \ ((val_binds, (inst_binds, cls_binds, final_env)), lie_alldecls, _) ->
159 checkTopLevelIds mod_name final_env `thenTc_`
161 -- Deal with constant or ambiguous InstIds. How could
162 -- there be ambiguous ones? They can only arise if a
163 -- top-level decl falls under the monomorphism
164 -- restriction, and no subsequent decl instantiates its
165 -- type. (Usually, ambiguous type variables are resolved
166 -- during the generalisation step.)
167 tcSimplifyTop lie_alldecls `thenTc` \ const_insts ->
169 localids = getEnv_LocalIds final_env
170 tycons = getEnv_TyCons final_env
171 classes = getEnv_Classes final_env
173 local_tycons = filter isLocallyDefined tycons
174 local_classes = filter isLocallyDefined classes
176 exported_ids = [v | v <- localids,
177 isExported v && not (isDataCon v) && not (isMethodSelId v)]
179 -- Backsubstitution. Monomorphic top-level decls may have
180 -- been instantiated by subsequent decls, and the final
181 -- simplification step may have instantiated some
182 -- ambiguous types. So, sadly, we need to back-substitute
183 -- over the whole bunch of bindings.
184 zonkBinds val_binds `thenNF_Tc` \ val_binds' ->
185 zonkBinds inst_binds `thenNF_Tc` \ inst_binds' ->
186 zonkBinds cls_binds `thenNF_Tc` \ cls_binds' ->
187 mapNF_Tc zonkInst const_insts `thenNF_Tc` \ const_insts' ->
188 mapNF_Tc (zonkId.TcId) exported_ids `thenNF_Tc` \ exported_ids' ->
192 (cls_binds', inst_binds', val_binds', const_insts'),
194 -- the next collection is just for mkInterface
195 (fixities, exported_ids', tycons, classes, inst_info),
197 (local_tycons, local_classes),
204 ty_decls_bag = listToBag ty_decls
205 cls_decls_bag = listToBag cls_decls
206 inst_decls_bag = listToBag inst_decls
211 %************************************************************************
213 \subsection{Error checking code}
215 %************************************************************************
218 checkTopLevelIds checks that Main.main or Main.mainPrimIO has correct type.
221 checkTopLevelIds :: FAST_STRING -> TcEnv s -> TcM s ()
222 checkTopLevelIds mod final_env
223 | mod /= SLIT("Main")
227 = tcSetEnv final_env (
228 tcLookupLocalValueByKey mainIdKey `thenNF_Tc` \ maybe_main ->
229 tcLookupLocalValueByKey mainPrimIOIdKey `thenNF_Tc` \ maybe_prim ->
230 tcLookupTyConByKey iOTyConKey `thenNF_Tc` \ io_tc ->
232 case (maybe_main, maybe_prim) of
233 (Just main, Nothing) -> tcAddErrCtxt mainCtxt $
234 unifyTauTy (applyTyCon io_tc [unitTy])
237 (Nothing, Just prim) -> tcAddErrCtxt primCtxt $
238 unifyTauTy (mkPrimIoTy unitTy)
241 (Just _ , Just _ ) -> failTc mainBothIdErr
242 (Nothing, Nothing) -> failTc mainNoneIdErr
246 = ppStr "main should have type IO ()"
249 = ppStr "mainPrimIO should have type PrimIO ()"
252 = ppStr "module Main contains definitions for both main and mainPrimIO"
255 = panic "ToDo: sort out mainIdKey"
256 -- ppStr "module Main does not contain a definition for main (or mainPrimIO)"