[project @ 1999-05-18 15:03:54 by simonpj]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcModule.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[TcModule]{Typechecking a whole module}
5
6 \begin{code}
7 module TcModule (
8         typecheckModule,
9         TcResults(..)
10     ) where
11
12 #include "HsVersions.h"
13
14 import CmdLineOpts      ( opt_D_dump_tc )
15 import HsSyn            ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..) )
16 import RnHsSyn          ( RenamedHsModule )
17 import TcHsSyn          ( TcMonoBinds, TypecheckedMonoBinds, 
18                           TypecheckedForeignDecl, TypecheckedRuleDecl,
19                           zonkTopBinds, zonkForeignExports, zonkRules
20                         )
21
22 import TcMonad
23 import Inst             ( Inst, emptyLIE, plusLIE )
24 import TcBinds          ( tcTopBindsAndThen )
25 import TcClassDcl       ( tcClassDecls2 )
26 import TcDefaults       ( tcDefaults )
27 import TcEnv            ( tcExtendGlobalValEnv, tcExtendTypeEnv,
28                           getEnvTyCons, getEnvClasses, tcLookupValueMaybe,
29                           explicitLookupValueByKey, tcSetValueEnv,
30                           tcLookupTyCon, initEnv, 
31                           ValueEnv, TcTyThing(..)
32                         )
33 import TcExpr           ( tcId )
34 import TcRules          ( tcRules )
35 import TcForeign        ( tcForeignImports, tcForeignExports )
36 import TcIfaceSig       ( tcInterfaceSigs )
37 import TcInstDcls       ( tcInstDecls1, tcInstDecls2 )
38 import TcInstUtil       ( buildInstanceEnvs, classDataCon, InstInfo )
39 import TcSimplify       ( tcSimplifyTop )
40 import TcTyClsDecls     ( tcTyAndClassDecls )
41 import TcTyDecls        ( mkDataBinds )
42 import TcType           ( TcType, typeToTcType,
43                           TcKind, kindToTcKind,
44                           newTyVarTy
45                         )
46
47 import RnMonad          ( RnNameSupply, getIfaceFixities, Fixities, InterfaceDetails )
48 import Bag              ( isEmptyBag )
49 import ErrUtils         ( Message,
50                           pprBagOfErrors, dumpIfSet
51                         )
52 import Id               ( Id, idType )
53 import Module           ( pprModuleName )
54 import Name             ( Name, nameUnique, isLocallyDefined, NamedThing(..) )
55 import TyCon            ( TyCon, tyConKind )
56 import DataCon          ( dataConId )
57 import Class            ( Class, classSelIds, classTyCon )
58 import Type             ( mkTyConApp, mkForAllTy,
59                           boxedTypeKind, getTyVar, Type )
60 import TysWiredIn       ( unitTy )
61 import PrelMods         ( mAIN_Name )
62 import PrelInfo         ( main_NAME, thinAirIdNames, setThinAirIds )
63 import TcUnify          ( unifyTauTy )
64 import Unique           ( Unique  )
65 import UniqSupply       ( UniqSupply )
66 import Maybes           ( maybeToBool )
67 import Util
68 import Bag              ( Bag, isEmptyBag )
69 import Outputable
70
71 import IOExts
72 \end{code}
73
74 Outside-world interface:
75 \begin{code}
76
77 -- Convenient type synonyms first:
78 data TcResults
79   = TcResults {
80         tc_binds   :: TypecheckedMonoBinds,
81         tc_tycons  :: [TyCon],
82         tc_classes :: [Class],
83         tc_insts   :: Bag InstInfo,             -- Instance declaration information
84         tc_fords   :: [TypecheckedForeignDecl], -- Foreign import & exports.
85         tc_rules   :: [TypecheckedRuleDecl],    -- Transformation rules
86         tc_env     :: ValueEnv,
87         tc_thinair :: [Id]                      -- The thin-air Ids
88     }
89
90 ---------------
91 typecheckModule
92         :: UniqSupply
93         -> RnNameSupply
94         -> InterfaceDetails
95         -> RenamedHsModule
96         -> IO (Maybe TcResults)
97
98 typecheckModule us rn_name_supply iface_det mod
99   = initTc us initEnv (tcModule rn_name_supply (getIfaceFixities iface_det) mod)
100                         >>= \ (maybe_result, warns, errs) ->
101                 
102     print_errs warns    >>
103     print_errs errs     >>
104
105     -- write the thin-air Id map
106     (case maybe_result of
107         Just results -> setThinAirIds (tc_thinair results)
108         Nothing      -> return ()
109     )                                                                   >>
110
111     dumpIfSet opt_D_dump_tc "Typechecked"
112         (case maybe_result of
113             Just results -> ppr (tc_binds results) 
114                             $$ 
115                             pp_rules (tc_rules results)
116             Nothing      -> text "Typecheck failed")    >>
117
118     return (if isEmptyBag errs then 
119                 maybe_result 
120             else 
121                 Nothing)
122
123 pp_rules [] = empty
124 pp_rules rs = vcat [ptext SLIT("{-# RULES"),
125                     nest 4 (vcat (map ppr rs)),
126                     ptext SLIT("#-}")]
127
128 print_errs errs
129   | isEmptyBag errs = return ()
130   | otherwise       = printErrs (pprBagOfErrors errs)
131 \end{code}
132
133 The internal monster:
134 \begin{code}
135 tcModule :: RnNameSupply        -- for renaming derivings
136          -> Fixities            -- needed for Show/Read derivings.
137          -> RenamedHsModule     -- input
138          -> TcM s TcResults     -- output
139
140 tcModule rn_name_supply fixities
141         (HsModule mod_name verion exports imports decls src_loc)
142   = tcAddSrcLoc src_loc $       -- record where we're starting
143
144     fixTc (\ ~(unf_env ,_) ->
145         -- unf_env is used for type-checking interface pragmas
146         -- which is done lazily [ie failure just drops the pragma
147         -- without having any global-failure effect].
148         -- 
149         -- unf_env is also used to get the pragam info
150         -- for imported dfuns and default methods
151
152             -- The knot for instance information.  This isn't used at all
153             -- till we type-check value declarations
154         fixTc ( \ ~(rec_inst_mapper, _, _, _) ->
155     
156                  -- Type-check the type and class decls
157                 tcTyAndClassDecls unf_env rec_inst_mapper decls `thenTc` \ env ->
158     
159                     -- Typecheck the instance decls, includes deriving
160                 tcSetEnv env (
161                 tcInstDecls1 unf_env decls mod_name fixities rn_name_supply
162                 )                               `thenTc` \ (inst_info, deriv_binds) ->
163     
164                 buildInstanceEnvs inst_info     `thenNF_Tc` \ inst_mapper ->
165     
166                 returnTc (inst_mapper, env, inst_info, deriv_binds)
167     
168         -- End of inner fix loop
169         ) `thenTc` \ (_, env, inst_info, deriv_binds) ->
170     
171         tcSetEnv env            (
172         
173             -- Default declarations
174         tcDefaults decls                `thenTc` \ defaulting_tys ->
175         tcSetDefaultTys defaulting_tys  $
176         
177         -- Create any necessary record selector Ids and their bindings
178         -- "Necessary" includes data and newtype declarations
179         -- We don't create bindings for dictionary constructors;
180         -- they are always fully applied, and the bindings are just there
181         -- to support partial applications
182         let
183             tycons       = getEnvTyCons env
184             classes      = getEnvClasses env
185             local_tycons  = filter isLocallyDefined tycons
186             local_classes = filter isLocallyDefined classes
187         in
188         mkDataBinds tycons              `thenTc` \ (data_ids, data_binds) ->
189         
190         -- Extend the global value environment with 
191         --      (a) constructors
192         --      (b) record selectors
193         --      (c) class op selectors
194         --      (d) default-method ids... where? I can't see where these are
195         --          put into the envt, and I'm worried that the zonking phase
196         --          will find they aren't there and complain.
197         tcExtendGlobalValEnv data_ids                           $
198         tcExtendGlobalValEnv (concat (map classSelIds classes)) $
199
200         -- Extend the TyCon envt with the tycons corresponding to
201         -- the classes, and the global value environment with the
202         -- corresponding data cons.
203         --  They are mentioned in types in interface files.
204         tcExtendGlobalValEnv (map (dataConId . classDataCon) classes)           $
205         tcExtendTypeEnv [ (getName tycon, (kindToTcKind (tyConKind tycon), Nothing, ATyCon tycon))
206                         | clas <- classes,
207                           let tycon = classTyCon clas
208                         ]                               $
209
210             -- Interface type signatures
211             -- We tie a knot so that the Ids read out of interfaces are in scope
212             --   when we read their pragmas.
213             -- What we rely on is that pragmas are typechecked lazily; if
214             --   any type errors are found (ie there's an inconsistency)
215             --   we silently discard the pragma
216         tcInterfaceSigs unf_env decls           `thenTc` \ sig_ids ->
217         tcExtendGlobalValEnv sig_ids            $
218
219             -- foreign import declarations next.
220         tcForeignImports decls          `thenTc`    \ (fo_ids, foi_decls) ->
221         tcExtendGlobalValEnv fo_ids             $
222
223         -- Value declarations next.
224         -- We also typecheck any extra binds that came out of the "deriving" process
225         tcTopBindsAndThen
226             (\ is_rec binds1 (binds2, thing) -> (binds1 `AndMonoBinds` binds2, thing))
227             (get_val_decls decls `ThenBinds` deriv_binds)
228             (   tcGetEnv                                `thenNF_Tc` \ env ->
229                 tcGetUnique                             `thenNF_Tc` \ uniq ->
230                 returnTc ((EmptyMonoBinds, env), emptyLIE)
231             )                           `thenTc` \ ((val_binds, final_env), lie_valdecls) ->
232         tcSetEnv final_env $
233
234             -- foreign export declarations next.
235         tcForeignExports decls          `thenTc`    \ (lie_fodecls, foe_binds, foe_decls) ->
236
237                 -- Second pass over class and instance declarations,
238                 -- to compile the bindings themselves.
239         tcInstDecls2  inst_info         `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
240         tcClassDecls2 decls             `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
241         tcRules decls                   `thenNF_Tc` \ (lie_rules,     rules) ->
242
243
244              -- Deal with constant or ambiguous InstIds.  How could
245              -- there be ambiguous ones?  They can only arise if a
246              -- top-level decl falls under the monomorphism
247              -- restriction, and no subsequent decl instantiates its
248              -- type.  (Usually, ambiguous type variables are resolved
249              -- during the generalisation step.)
250         let
251             lie_alldecls = lie_valdecls  `plusLIE`
252                            lie_instdecls `plusLIE`
253                            lie_clasdecls `plusLIE`
254                            lie_fodecls   `plusLIE`
255                            lie_rules
256         in
257         tcSimplifyTop lie_alldecls                      `thenTc` \ const_inst_binds ->
258
259                 -- Check that Main defines main
260         (if mod_name == mAIN_Name then
261                 tcLookupValueMaybe main_NAME    `thenNF_Tc` \ maybe_main ->
262                 checkTc (maybeToBool maybe_main) noMainErr
263          else
264                 returnTc ()
265         )                                       `thenTc_`
266
267             -- Backsubstitution.    This must be done last.
268             -- Even tcSimplifyTop may do some unification.
269         let
270             all_binds = data_binds              `AndMonoBinds` 
271                         val_binds               `AndMonoBinds`
272                         inst_binds              `AndMonoBinds`
273                         cls_binds               `AndMonoBinds`
274                         const_inst_binds        `AndMonoBinds`
275                         foe_binds
276         in
277         zonkTopBinds all_binds          `thenNF_Tc` \ (all_binds', really_final_env)  ->
278         tcSetValueEnv really_final_env  $
279         zonkForeignExports foe_decls    `thenNF_Tc` \ foe_decls' ->
280         zonkRules rules                 `thenNF_Tc` \ rules' ->
281
282         let
283            thin_air_ids = map (explicitLookupValueByKey really_final_env . nameUnique) thinAirIdNames
284                 -- When looking up the thin-air names we must use
285                 -- a global env that includes the zonked locally-defined Ids too
286                 -- Hence using really_final_env
287         in
288         returnTc (really_final_env, 
289                   (TcResults {  tc_binds   = all_binds', 
290                                 tc_tycons  = local_tycons,
291                                 tc_classes = local_classes,
292                                 tc_insts   = inst_info,
293                                 tc_fords   = foi_decls ++ foe_decls',
294                                 tc_rules   = rules',
295                                 tc_env     = really_final_env,
296                                 tc_thinair = thin_air_ids
297                  }))
298         )
299
300     -- End of outer fix loop
301     ) `thenTc` \ (final_env, stuff) ->
302     returnTc stuff
303
304 get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
305 \end{code}
306
307
308 \begin{code}
309 noMainErr
310   = hsep [ptext SLIT("Module"), quotes (pprModuleName mAIN_Name), 
311           ptext SLIT("must include a definition for"), quotes (ppr main_NAME)]
312 \end{code}
313