[project @ 1997-05-26 01:32:22 by sof]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcModule.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
3 %
4 \section[TcModule]{Typechecking a whole module}
5
6 \begin{code}
7 #include "HsVersions.h"
8
9 module TcModule (
10         typecheckModule,
11         SYN_IE(TcResults),
12         SYN_IE(TcResultBinds),
13         SYN_IE(TcSpecialiseRequests),
14         SYN_IE(TcDDumpDeriv)
15     ) where
16
17 IMP_Ubiq(){-uitous-}
18
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
24                         )
25 import RnHsSyn          ( SYN_IE(RenamedHsModule), RenamedFixityDecl(..) )
26 import TcHsSyn          ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
27                           SYN_IE(TypecheckedDictBinds),
28                           TcIdOcc(..), zonkBinds )
29
30 import TcMonad
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 )
49
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 )
56 import Pretty
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 TysWiredIn       ( unitTy )
62 import PrelMods         ( gHC_MAIN, mAIN )
63 import PrelInfo         ( main_NAME, mainPrimIO_NAME, ioTyCon_NAME, primIoTyCon_NAME )
64 import TyVar            ( GenTyVar, SYN_IE(TyVarEnv), nullTyVarEnv )
65 import Unify            ( unifyTauTy )
66 import UniqFM           ( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
67                           filterUFM, eltsUFM )
68 import Unique           ( Unique  )
69 import UniqSupply       ( UniqSupply )
70 import Util
71 import Bag              ( Bag, isEmptyBag )
72
73 import FiniteMap        ( emptyFM, FiniteMap )
74
75 import Outputable       ( Outputable(..), PprStyle )
76
77 tycon_specs = emptyFM
78 \end{code}
79
80 Outside-world interface:
81 \begin{code}
82 -- Convenient type synonyms first:
83 type TcResults
84   = (TcResultBinds,
85      [TyCon], [Class],
86      Bag InstInfo,              -- Instance declaration information
87      TcSpecialiseRequests,
88      TcDDumpDeriv)
89
90 type TcResultBinds
91   = (TypecheckedHsBinds,        -- record selector binds
92      TypecheckedHsBinds,        -- binds from class decls; does NOT
93                                 -- include default-methods bindings
94      TypecheckedHsBinds,        -- binds from instance decls; INCLUDES
95                                 -- class default-methods binds
96      TypecheckedHsBinds,        -- binds from value decls
97
98      TypecheckedHsBinds)        -- constant instance binds
99
100 type TcSpecialiseRequests
101   = FiniteMap TyCon [(Bool, [Maybe Type])]
102     -- source tycon specialisation requests
103
104 type TcDDumpDeriv
105   = PprStyle -> Doc
106
107 ---------------
108 typecheckModule
109         :: UniqSupply
110         -> RnNameSupply
111         -> RenamedHsModule
112         -> MaybeErr
113             (TcResults,         -- if all goes well...
114              Bag Warning)       -- (we can still get warnings)
115             (Bag Error,         -- if we had errors...
116              Bag Warning)
117
118 typecheckModule us rn_name_supply mod
119   = initTc us (tcModule rn_name_supply mod)
120 \end{code}
121
122 The internal monster:
123 \begin{code}
124 tcModule :: RnNameSupply        -- for renaming derivings
125          -> RenamedHsModule     -- input
126          -> TcM s TcResults     -- output
127
128 tcModule rn_name_supply
129         (HsModule mod_name verion exports imports fixities decls src_loc)
130   = tcAddSrcLoc src_loc $       -- record where we're starting
131
132         -- Tie the knot for inteface-file value declaration signatures
133         -- This info is only used inside the knot for type-checking the
134         -- pragmas, which is done lazily [ie failure just drops the pragma
135         -- without having any global-failure effect].
136
137     -- trace "tc1" $
138
139     fixTc (\ ~(_, _, _, _, _, _, sig_ids) ->
140
141         -- trace "tc2" $
142         tcExtendGlobalValEnv sig_ids (
143
144         -- The knot for instance information.  This isn't used at all
145         -- till we type-check value declarations
146         fixTc ( \ ~(rec_inst_mapper, _, _, _, _) ->
147
148              -- Type-check the type and class decls
149             -- trace "tcTyAndClassDecls:"       $
150             tcTyAndClassDecls1 rec_inst_mapper decls    `thenTc` \ env ->
151
152             -- trace "tc3" $
153                 -- Typecheck the instance decls, includes deriving
154             tcSetEnv env (
155             -- trace "tcInstDecls:"     $
156             tcInstDecls1 decls mod_name rn_name_supply
157             )                                   `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
158
159             -- trace "tc4" $
160             buildInstanceEnvs inst_info `thenTc` \ inst_mapper ->
161
162             returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
163
164         ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
165
166         -- trace "tc5" $
167         tcSetEnv env (
168
169             -- Default declarations
170         tcDefaults decls                `thenTc` \ defaulting_tys ->
171         tcSetDefaultTys defaulting_tys  ( -- for the iface sigs...
172
173         -- Create any necessary record selector Ids and their bindings
174         -- "Necessary" includes data and newtype declarations
175         let
176                 tycons   = getEnv_TyCons env
177                 classes  = getEnv_Classes env
178         in
179         mkDataBinds tycons              `thenTc` \ (data_ids, data_binds) ->
180
181         -- Extend the global value environment with 
182         --      a) constructors
183         --      b) record selectors
184         --      c) class op selectors
185         --      d) default-method ids
186         tcExtendGlobalValEnv data_ids                           $
187         tcExtendGlobalValEnv (concat (map classGlobalIds classes))      $
188
189             -- Interface type signatures
190             -- We tie a knot so that the Ids read out of interfaces are in scope
191             --   when we read their pragmas.
192             -- What we rely on is that pragmas are typechecked lazily; if
193             --   any type errors are found (ie there's an inconsistency)
194             --   we silently discard the pragma
195         tcInterfaceSigs decls           `thenTc` \ sig_ids ->
196         tcGetEnv                        `thenNF_Tc` \ env ->
197         -- trace "tc6" $
198
199         returnTc (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
200
201     )))) `thenTc` \ (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, _) ->
202
203     -- trace "tc7" $
204     tcSetEnv env (                              -- to the end...
205     tcSetDefaultTys defaulting_tys (            -- ditto
206
207         -- Value declarations next.
208         -- We also typecheck any extra binds that came out of the "deriving" process
209     -- trace "tcBinds:"                 $
210     tcBindsAndThen
211         (\ binds1 (binds2, thing) -> (binds1 `ThenBinds` binds2, thing))
212         (get_val_decls decls `ThenBinds` deriv_binds)
213         (       -- Second pass over instance declarations,
214                 -- to compile the bindings themselves.
215             -- trace "tc8" $
216             tcInstDecls2  inst_info     `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
217             tcClassDecls2 decls         `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
218             tcCheckMainSig mod_name     `thenTc_` 
219             tcGetEnv                    `thenNF_Tc` \ env ->
220             returnTc ( (EmptyBinds, (inst_binds, cls_binds, env)),
221                        lie_instdecls `plusLIE` lie_clasdecls
222                      )
223         )
224
225         `thenTc` \ ((val_binds, (inst_binds, cls_binds, final_env)), lie_alldecls) ->
226
227         -- Deal with constant or ambiguous InstIds.  How could
228         -- there be ambiguous ones?  They can only arise if a
229         -- top-level decl falls under the monomorphism
230         -- restriction, and no subsequent decl instantiates its
231         -- type.  (Usually, ambiguous type variables are resolved
232         -- during the generalisation step.)
233     -- trace "tc9" $
234     tcSimplifyTop lie_alldecls                  `thenTc` \ const_insts ->
235
236
237         -- Backsubstitution.  Monomorphic top-level decls may have
238         -- been instantiated by subsequent decls, and the final
239         -- simplification step may have instantiated some
240         -- ambiguous types.  So, sadly, we need to back-substitute
241         -- over the whole bunch of bindings.
242         -- 
243         -- More horrible still, we have to do it in a careful order, so that
244         -- all the TcIds are in scope when we come across them.
245         -- 
246         -- These bindings ought really to be bundled together in a huge
247         -- recursive group, but HsSyn doesn't have recursion among Binds, only
248         -- among MonoBinds.  Sigh again.
249     zonkBinds nullTyVarEnv nullIdEnv (MonoBind const_insts [] nonRecursive)
250                                                         `thenNF_Tc` \ (const_insts', ve1) ->
251     zonkBinds nullTyVarEnv ve1 val_binds                `thenNF_Tc` \ (val_binds', ve2) ->
252
253     zonkBinds nullTyVarEnv ve2 data_binds       `thenNF_Tc` \ (data_binds', _) ->
254     zonkBinds nullTyVarEnv ve2 inst_binds       `thenNF_Tc` \ (inst_binds', _) ->
255     zonkBinds nullTyVarEnv ve2 cls_binds        `thenNF_Tc` \ (cls_binds', _) ->
256
257     let
258         localids = getEnv_LocalIds final_env
259         tycons   = getEnv_TyCons   final_env
260         classes  = getEnv_Classes  final_env
261
262         local_tycons  = filter isLocallyDefined tycons
263         local_classes = filter isLocallyDefined classes
264     in
265         -- FINISHED AT LAST
266     returnTc (
267         (data_binds', cls_binds', inst_binds', val_binds', const_insts'),
268
269         local_tycons, local_classes, inst_info, tycon_specs,
270
271         ddump_deriv
272     )))
273
274 get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
275 \end{code}
276
277
278 \begin{code}
279 tcCheckMainSig mod_name
280   | not is_main && not is_ghc_main
281   = returnTc ()         -- A non-main module
282
283   | otherwise
284   =     -- Check that main is defined
285     tcLookupTyCon tycon_name                    `thenTc` \ (_,_,tycon) ->
286     tcLookupLocalValue main_name                `thenNF_Tc` \ maybe_main_id ->
287     case maybe_main_id of {
288         Nothing  -> failTc (noMainErr mod_name main_name);
289         Just main_id   ->
290
291         -- Check that it has the right type (or a more general one)
292     let
293         expected_ty | isSynTyCon tycon = mkSynTy tycon [unitTy]
294                     | otherwise        = applyTyCon tycon [unitTy]
295                 -- This is bizarre.  There ought to be a suitable function in Type.lhs!
296     in
297     tcInstType [] expected_ty                   `thenNF_Tc` \ expected_tau ->
298     tcId main_name                              `thenNF_Tc` \ (_, lie, main_tau) ->
299     tcSetErrCtxt (mainTyCheckCtxt main_name) $
300     unifyTauTy expected_tau
301                main_tau                         `thenTc_`
302     checkTc (isEmptyBag lie) (mainTyMisMatch main_name expected_ty (idType main_id))
303     }
304   where
305     is_main     = mod_name == mAIN
306     is_ghc_main = mod_name == gHC_MAIN
307
308     main_name | is_main   = main_NAME
309               | otherwise = mainPrimIO_NAME
310
311     tycon_name | is_main   = ioTyCon_NAME
312                | otherwise = primIoTyCon_NAME
313
314 mainTyCheckCtxt main_name sty
315   = hsep [ptext SLIT("When checking that"), ppr sty main_name, ptext SLIT("has the required type")]
316
317 noMainErr mod_name main_name sty
318   = hsep [ptext SLIT("Module"), pprModule sty mod_name, 
319            ptext SLIT("must include a definition for"), ppr sty main_name]
320
321 mainTyMisMatch :: Name -> Type -> TcType s -> Error
322 mainTyMisMatch main_name expected actual sty
323   = hang (hsep [ppr sty main_name, ptext SLIT("has the wrong type")])
324          4 (vcat [
325                         hsep [ptext SLIT("Expected:"), ppr sty expected],
326                         hsep [ptext SLIT("Inferred:"), ppr sty actual]
327                      ])
328 \end{code}