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