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 import TcIfaceSig ( tcInterfaceSigs )
31 import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
32 import TcInstUtil ( buildInstanceEnvs, InstInfo )
33 import TcSimplify ( tcSimplifyTop )
34 import TcTyClsDecls ( tcTyAndClassDecls1 )
36 import Bag ( listToBag )
37 import Class ( GenClass )
38 import Id ( GenId, isDataCon, isMethodSelId, idType )
39 import Maybes ( catMaybes )
40 import Name ( Name(..) )
41 import Outputable ( isExported )
42 import PrelInfo ( unitTy, mkPrimIoTy )
44 import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
45 import TyCon ( TyCon )
46 import Type ( applyTyCon )
47 import Unify ( unifyTauTy )
48 import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
50 import Unique ( iOTyConKey, mainIdKey, mainPrimIOIdKey )
54 import FiniteMap ( emptyFM )
61 tcModule :: GlobalNameMappers -- final renamer info for derivings
62 -> RenamedHsModule -- input
63 -> TcM s ((TypecheckedHsBinds, -- binds from class decls; does NOT
64 -- include default-methods bindings
65 TypecheckedHsBinds, -- binds from instance decls; INCLUDES
66 -- class default-methods binds
67 TypecheckedHsBinds, -- binds from value decls
69 [(Id, TypecheckedHsExpr)]), -- constant instance binds
71 ([RenamedFixityDecl], [Id], UniqFM TyCon, UniqFM Class, Bag InstInfo),
72 -- things for the interface generator
74 (UniqFM TyCon, UniqFM Class),
75 -- environments of info from this module only
77 FiniteMap TyCon [(Bool, [Maybe Type])],
78 -- source tycon specialisation requests
80 PprStyle -> Pretty) -- -ddump-deriving info
82 tcModule renamer_name_funs
83 (HsModule mod_name exports imports fixities
84 ty_decls specdata_sigs cls_decls inst_decls specinst_sigs
85 default_decls val_decls sigs src_loc)
87 = ASSERT(null imports)
89 tcAddSrcLoc src_loc $ -- record where we're starting
91 -- Tie the knot for inteface-file value declaration signatures
92 -- This info is only used inside the knot for type-checking the
93 -- pragmas, which is done lazily [ie failure just drops the pragma
94 -- without having any global-failure effect].
96 fixTc (\ ~(_, _, _, _, _, sig_ids) ->
97 tcExtendGlobalValEnv sig_ids (
99 -- The knot for instance information. This isn't used at all
100 -- till we type-check value declarations
101 fixTc ( \ ~(rec_inst_mapper, _, _, _, _) ->
103 -- Type-check the type and class decls
104 trace "tcTyAndClassDecls:" $
105 tcTyAndClassDecls1 rec_inst_mapper ty_decls_bag cls_decls_bag
108 -- Typecheck the instance decls, includes deriving
110 trace "tcInstDecls:" $
111 tcInstDecls1 inst_decls_bag specinst_sigs
112 mod_name renamer_name_funs fixities
113 ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
115 buildInstanceEnvs inst_info `thenTc` \ inst_mapper ->
117 returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
119 ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
122 -- Default declarations
123 tcDefaults default_decls `thenTc` \ defaulting_tys ->
124 tcSetDefaultTys defaulting_tys ( -- for the iface sigs...
126 -- Interface type signatures
127 -- We tie a knot so that the Ids read out of interfaces are in scope
128 -- when we read their pragmas.
129 -- What we rely on is that pragmas are typechecked lazily; if
130 -- any type errors are found (ie there's an inconsistency)
131 -- we silently discard the pragma
132 tcInterfaceSigs sigs `thenTc` \ sig_ids ->
134 returnTc (env, inst_info, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
136 )))) `thenTc` \ (env, inst_info, deriv_binds, ddump_deriv, defaulting_tys, _) ->
138 tcSetEnv env ( -- to the end...
139 tcSetDefaultTys defaulting_tys ( -- ditto
141 -- Value declarations next.
142 -- We also typecheck any extra binds that came out of the "deriving" process
145 (\ binds1 (binds2, thing) -> (binds1 `ThenBinds` binds2, thing))
146 (val_decls `ThenBinds` deriv_binds)
147 ( -- Second pass over instance declarations,
148 -- to compile the bindings themselves.
149 tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
150 tcClassDecls2 cls_decls_bag `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
151 tcGetEnv `thenNF_Tc` \ env ->
152 returnTc ( (EmptyBinds, (inst_binds, cls_binds, env)),
153 lie_instdecls `plusLIE` lie_clasdecls,
156 `thenTc` \ ((val_binds, (inst_binds, cls_binds, final_env)), lie_alldecls, _) ->
158 checkTopLevelIds mod_name final_env `thenTc_`
160 -- Deal with constant or ambiguous InstIds. How could
161 -- there be ambiguous ones? They can only arise if a
162 -- top-level decl falls under the monomorphism
163 -- restriction, and no subsequent decl instantiates its
164 -- type. (Usually, ambiguous type variables are resolved
165 -- during the generalisation step.)
166 tcSimplifyTop lie_alldecls `thenTc` \ const_insts ->
168 localids = getEnv_LocalIds final_env
169 tycons = getEnv_TyCons final_env
170 classes = getEnv_Classes final_env
172 local_tycons = filterUFM isLocallyDefined tycons
173 local_classes = filterUFM isLocallyDefined classes
175 exported_ids = [v | v <- eltsUFM localids,
176 isExported v && not (isDataCon v) && not (isMethodSelId v)]
178 -- Backsubstitution. Monomorphic top-level decls may have
179 -- been instantiated by subsequent decls, and the final
180 -- simplification step may have instantiated some
181 -- ambiguous types. So, sadly, we need to back-substitute
182 -- over the whole bunch of bindings.
183 zonkBinds val_binds `thenNF_Tc` \ val_binds' ->
184 zonkBinds inst_binds `thenNF_Tc` \ inst_binds' ->
185 zonkBinds cls_binds `thenNF_Tc` \ cls_binds' ->
186 mapNF_Tc zonkInst const_insts `thenNF_Tc` \ const_insts' ->
187 mapNF_Tc (zonkId.TcId) exported_ids `thenNF_Tc` \ exported_ids' ->
191 (cls_binds', inst_binds', val_binds', const_insts'),
193 -- the next collection is just for mkInterface
194 (fixities, exported_ids', tycons, classes, inst_info),
196 (local_tycons, local_classes),
203 ty_decls_bag = listToBag ty_decls
204 cls_decls_bag = listToBag cls_decls
205 inst_decls_bag = listToBag inst_decls
210 %************************************************************************
212 \subsection{Error checking code}
214 %************************************************************************
217 checkTopLevelIds checks that Main.main or Main.mainPrimIO has correct type.
220 checkTopLevelIds :: FAST_STRING -> TcEnv s -> TcM s ()
221 checkTopLevelIds mod final_env
222 = if (mod /= SLIT("Main")) then
225 case (lookupUFM_Directly localids mainIdKey,
226 lookupUFM_Directly localids mainPrimIOIdKey) of
227 (Just main, Nothing) -> tcAddErrCtxt mainCtxt $
228 unifyTauTy ty_main (idType main)
229 (Nothing, Just prim) -> tcAddErrCtxt primCtxt $
230 unifyTauTy ty_prim (idType prim)
231 (Just _ , Just _ ) -> failTc mainBothIdErr
232 (Nothing, Nothing) -> failTc mainNoneIdErr
234 localids = getEnv_LocalIds final_env
235 tycons = getEnv_TyCons final_env
237 io_tc = lookupWithDefaultUFM_Directly tycons io_panic iOTyConKey
238 io_panic = panic "TcModule: type IO not in scope"
240 ty_main = applyTyCon io_tc [unitTy]
241 ty_prim = mkPrimIoTy unitTy
245 = ppStr "main should have type IO ()"
248 = ppStr "mainPrimIO should have type PrimIO ()"
251 = ppStr "module Main contains definitions for both main and mainPrimIO"
254 = panic "ToDo: sort out mainIdKey"
255 -- ppStr "module Main does not contain a definition for main (or mainPrimIO)"