[project @ 2000-09-07 10:14:52 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, opt_D_dump_types, opt_PprStyle_Debug )
15 import HsSyn            ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..) )
16 import HsTypes          ( toHsType )
17 import RnHsSyn          ( RenamedHsModule )
18 import TcHsSyn          ( TcMonoBinds, TypecheckedMonoBinds, 
19                           TypecheckedForeignDecl, TypecheckedRuleDecl,
20                           zonkTopBinds, zonkForeignExports, zonkRules
21                         )
22
23 import TcMonad
24 import Inst             ( Inst, emptyLIE, plusLIE )
25 import TcBinds          ( tcTopBindsAndThen )
26 import TcClassDcl       ( tcClassDecls2, mkImplicitClassBinds )
27 import TcDefaults       ( tcDefaults )
28 import TcEnv            ( tcExtendGlobalValEnv, tcExtendTypeEnv,
29                           getEnvTyCons, getEnvClasses, tcLookupValueByKeyMaybe,
30                           tcSetValueEnv, tcSetInstEnv,
31                           initEnv, 
32                           ValueEnv, 
33                         )
34 import TcRules          ( tcRules )
35 import TcForeign        ( tcForeignImports, tcForeignExports )
36 import TcIfaceSig       ( tcInterfaceSigs )
37 import TcInstDcls       ( tcInstDecls1, tcInstDecls2 )
38 import TcInstUtil       ( buildInstanceEnv, InstInfo )
39 import TcSimplify       ( tcSimplifyTop )
40 import TcTyClsDecls     ( tcTyAndClassDecls )
41 import TcTyDecls        ( mkImplicitDataBinds )
42 import TcType           ( TcType, TcKind )
43
44 import RnMonad          ( RnNameSupply, FixityEnv )
45 import Bag              ( isEmptyBag )
46 import ErrUtils         ( Message, printErrorsAndWarnings, dumpIfSet )
47 import Id               ( Id, idType, idName )
48 import Module           ( pprModuleName, mkThisModule )
49 import Name             ( Name, nameUnique, nameOccName, isLocallyDefined, isGlobalName,
50                           toRdrName, nameEnvElts, NamedThing(..)
51                         )
52 import OccName          ( isSysOcc )
53 import TyCon            ( TyCon, tyConKind, tyConClass_maybe )
54 import Class            ( Class, classSelIds, classTyCon )
55 import PrelInfo         ( mAIN_Name )
56 import Unique           ( Unique, mainKey )
57 import UniqSupply       ( UniqSupply )
58 import Maybes           ( maybeToBool )
59 import Util
60 import Bag              ( Bag, isEmptyBag )
61 import Outputable
62 \end{code}
63
64 Outside-world interface:
65 \begin{code}
66
67 -- Convenient type synonyms first:
68 data TcResults
69   = TcResults {
70         tc_binds   :: TypecheckedMonoBinds,
71         tc_tycons  :: [TyCon],
72         tc_classes :: [Class],
73         tc_insts   :: Bag InstInfo,             -- Instance declaration information
74         tc_fords   :: [TypecheckedForeignDecl], -- Foreign import & exports.
75         tc_rules   :: [TypecheckedRuleDecl],    -- Transformation rules
76         tc_env     :: ValueEnv
77     }
78
79 ---------------
80 typecheckModule
81         :: UniqSupply
82         -> RnNameSupply
83         -> FixityEnv
84         -> RenamedHsModule
85         -> IO (Maybe TcResults)
86
87 typecheckModule us rn_name_supply fixity_env mod
88   = initTc us initEnv (tcModule rn_name_supply fixity_env mod)  >>= \ (maybe_result, warns, errs) ->
89                 
90     printErrorsAndWarnings errs warns           >>
91         
92     (case maybe_result of
93         Nothing -> return ()
94         Just results -> dumpIfSet opt_D_dump_types "Type signatures" (dump_sigs results) >>
95                         dumpIfSet opt_D_dump_tc    "Typechecked"     (dump_tc   results)
96     )                                           >>
97                         
98     return (if isEmptyBag errs then 
99                 maybe_result 
100             else 
101                 Nothing)
102
103 dump_tc results
104   = ppr (tc_binds results) $$ pp_rules (tc_rules results) 
105
106 dump_sigs results       -- Print type signatures
107   =     -- Convert to HsType so that we get source-language style printing
108         -- And sort by RdrName
109     vcat $ map ppr_sig $ sortLt lt_sig $
110     [(toRdrName id, toHsType (idType id)) | id <- nameEnvElts (tc_env results), 
111                                             want_sig id
112     ]
113   where
114     lt_sig (n1,_) (n2,_) = n1 < n2
115     ppr_sig (n,t)        = ppr n <+> dcolon <+> ppr t
116
117     want_sig id | opt_PprStyle_Debug = True
118                 | otherwise          = isLocallyDefined n && 
119                                        isGlobalName n && 
120                                        not (isSysOcc (nameOccName n))
121                                      where
122                                        n = idName id
123
124 pp_rules [] = empty
125 pp_rules rs = vcat [ptext SLIT("{-# RULES"),
126                     nest 4 (vcat (map ppr rs)),
127                     ptext SLIT("#-}")]
128 \end{code}
129
130 The internal monster:
131 \begin{code}
132 tcModule :: RnNameSupply        -- for renaming derivings
133          -> FixityEnv           -- needed for Show/Read derivings.
134          -> RenamedHsModule     -- input
135          -> TcM s TcResults     -- output
136
137 tcModule rn_name_supply fixities
138         (HsModule mod_name _ _ _ decls _ src_loc)
139   = tcAddSrcLoc src_loc $       -- record where we're starting
140
141     fixTc (\ ~(unf_env ,_) ->
142         -- unf_env is used for type-checking interface pragmas
143         -- which is done lazily [ie failure just drops the pragma
144         -- without having any global-failure effect].
145         -- 
146         -- unf_env is also used to get the pragam info
147         -- for imported dfuns and default methods
148
149                  -- Type-check the type and class decls
150         tcTyAndClassDecls unf_env decls `thenTc` \ env ->
151     
152                  -- Typecheck the instance decls, includes deriving
153         tcSetEnv env $
154
155         tcInstDecls1 unf_env decls 
156                      (mkThisModule mod_name)
157                      fixities rn_name_supply    `thenTc` \ (inst_info, deriv_binds) ->
158     
159         buildInstanceEnv inst_info      `thenNF_Tc` \ inst_env ->
160
161         tcSetInstEnv inst_env $
162         let
163             classes      = getEnvClasses env
164             tycons       = getEnvTyCons env     -- INCLUDES tycons derived from classes
165             local_classes = filter isLocallyDefined classes
166             local_tycons  = [ tc | tc <- tycons,
167                                    isLocallyDefined tc,
168                                    Nothing <- [tyConClass_maybe tc]
169                             ]
170                                 -- For local_tycons, filter out the ones derived from classes
171                                 -- Otherwise the latter show up in interface files
172         in
173         
174             -- Default declarations
175         tcDefaults decls                `thenTc` \ defaulting_tys ->
176         tcSetDefaultTys defaulting_tys  $
177         
178         -- Interface type signatures
179         -- We tie a knot so that the Ids read out of interfaces are in scope
180         --   when we read their pragmas.
181         -- What we rely on is that pragmas are typechecked lazily; if
182         --   any type errors are found (ie there's an inconsistency)
183         --   we silently discard the pragma
184         -- We must do this before mkImplicitDataBinds (which comes next), since
185         -- the latter looks up unpackCStringId, for example, which is usually 
186         -- imported
187         tcInterfaceSigs unf_env decls           `thenTc` \ sig_ids ->
188         tcExtendGlobalValEnv sig_ids            $
189
190         -- Create any necessary record selector Ids and their bindings
191         -- "Necessary" includes data and newtype declarations
192         -- We don't create bindings for dictionary constructors;
193         -- they are always fully applied, and the bindings are just there
194         -- to support partial applications
195         mkImplicitDataBinds tycons              `thenTc`    \ (data_ids, imp_data_binds) ->
196         mkImplicitClassBinds classes            `thenNF_Tc` \ (cls_ids,  imp_cls_binds) ->
197         
198         -- Extend the global value environment with 
199         --      (a) constructors
200         --      (b) record selectors
201         --      (c) class op selectors
202         --      (d) default-method ids... where? I can't see where these are
203         --          put into the envt, and I'm worried that the zonking phase
204         --          will find they aren't there and complain.
205         tcExtendGlobalValEnv data_ids           $
206         tcExtendGlobalValEnv cls_ids            $
207
208             -- foreign import declarations next.
209         tcForeignImports decls          `thenTc`    \ (fo_ids, foi_decls) ->
210         tcExtendGlobalValEnv fo_ids             $
211
212         -- Value declarations next.
213         -- We also typecheck any extra binds that came out of the "deriving" process
214         tcTopBindsAndThen
215             (\ is_rec binds1 (binds2, thing) -> (binds1 `AndMonoBinds` binds2, thing))
216             (get_val_decls decls `ThenBinds` deriv_binds)
217             (   tcGetEnv                                `thenNF_Tc` \ env ->
218                 tcGetUnique                             `thenNF_Tc` \ uniq ->
219                 returnTc ((EmptyMonoBinds, env), emptyLIE)
220             )                           `thenTc` \ ((val_binds, final_env), lie_valdecls) ->
221         tcSetEnv final_env $
222
223             -- foreign export declarations next.
224         tcForeignExports decls          `thenTc`    \ (lie_fodecls, foe_binds, foe_decls) ->
225
226                 -- Second pass over class and instance declarations,
227                 -- to compile the bindings themselves.
228         tcInstDecls2  inst_info         `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
229         tcClassDecls2 decls             `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
230         tcRules decls                   `thenNF_Tc` \ (lie_rules,     rules) ->
231
232
233              -- Deal with constant or ambiguous InstIds.  How could
234              -- there be ambiguous ones?  They can only arise if a
235              -- top-level decl falls under the monomorphism
236              -- restriction, and no subsequent decl instantiates its
237              -- type.  (Usually, ambiguous type variables are resolved
238              -- during the generalisation step.)
239         let
240             lie_alldecls = lie_valdecls  `plusLIE`
241                            lie_instdecls `plusLIE`
242                            lie_clasdecls `plusLIE`
243                            lie_fodecls   `plusLIE`
244                            lie_rules
245         in
246         tcSimplifyTop lie_alldecls                      `thenTc` \ const_inst_binds ->
247
248                 -- Check that Main defines main
249         (if mod_name == mAIN_Name then
250                 tcLookupValueByKeyMaybe mainKey         `thenNF_Tc` \ maybe_main ->
251                 checkTc (maybeToBool maybe_main) noMainErr
252          else
253                 returnTc ()
254         )                                       `thenTc_`
255
256             -- Backsubstitution.    This must be done last.
257             -- Even tcSimplifyTop may do some unification.
258         let
259             all_binds = imp_data_binds          `AndMonoBinds` 
260                         imp_cls_binds           `AndMonoBinds` 
261                         val_binds               `AndMonoBinds`
262                         inst_binds              `AndMonoBinds`
263                         cls_dm_binds            `AndMonoBinds`
264                         const_inst_binds        `AndMonoBinds`
265                         foe_binds
266         in
267         zonkTopBinds all_binds          `thenNF_Tc` \ (all_binds', really_final_env)  ->
268         tcSetValueEnv really_final_env  $
269         zonkForeignExports foe_decls    `thenNF_Tc` \ foe_decls' ->
270         zonkRules rules                 `thenNF_Tc` \ rules' ->
271
272         returnTc (really_final_env, 
273                   (TcResults {  tc_binds   = all_binds', 
274                                 tc_tycons  = local_tycons,
275                                 tc_classes = local_classes,
276                                 tc_insts   = inst_info,
277                                 tc_fords   = foi_decls ++ foe_decls',
278                                 tc_rules   = rules',
279                                 tc_env     = really_final_env
280                  }))
281
282     -- End of outer fix loop
283     ) `thenTc` \ (final_env, stuff) ->
284     returnTc stuff
285
286 get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
287 \end{code}
288
289
290 \begin{code}
291 noMainErr
292   = hsep [ptext SLIT("Module"), quotes (pprModuleName mAIN_Name), 
293           ptext SLIT("must include a definition for"), quotes (ptext SLIT("main"))]
294 \end{code}
295