[project @ 2001-07-12 16:21:22 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, typecheckIface, typecheckStmt, typecheckExpr,
9         TcResults(..)
10     ) where
11
12 #include "HsVersions.h"
13
14 import CmdLineOpts      ( DynFlag(..), DynFlags, dopt )
15 import HsSyn            ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
16                           Stmt(..), InPat(..), HsMatchContext(..), HsDoContext(..), RuleDecl(..),
17                           isIfaceRuleDecl, nullBinds, andMonoBindList, mkSimpleMatch, placeHolderType
18                         )
19 import PrelNames        ( SyntaxMap, mAIN_Name, mainName, ioTyConName, printName,
20                           returnIOName, bindIOName, failIOName, 
21                           itName
22                         )
23 import MkId             ( unsafeCoerceId )
24 import RnHsSyn          ( RenamedHsBinds, RenamedHsDecl, RenamedStmt,
25                           RenamedHsExpr )
26 import TcHsSyn          ( TypecheckedMonoBinds, TypecheckedHsExpr,
27                           TypecheckedForeignDecl, TypecheckedRuleDecl,
28                           zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet,
29                           zonkExpr, zonkIdBndr
30                         )
31
32 import MkIface          ( pprModDetails )
33 import TcExpr           ( tcMonoExpr )
34 import TcMonad
35 import TcMType          ( unifyTauTy, newTyVarTy, zonkTcType, tcInstType )
36 import TcType           ( Type, liftedTypeKind, openTypeKind,
37                           tyVarsOfType, tidyType, tcFunResultTy,
38                           mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys
39                         )
40 import TcMatches        ( tcStmtsAndThen )
41 import Inst             ( emptyLIE, plusLIE )
42 import TcBinds          ( tcTopBinds )
43 import TcClassDcl       ( tcClassDecls2 )
44 import TcDefaults       ( tcDefaults, defaultDefaultTys )
45 import TcEnv            ( TcEnv, RecTcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv, tcLookup_maybe,
46                           isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv,
47                           tcExtendGlobalTypeEnv, tcLookupGlobalId, tcLookupTyCon,
48                           TcTyThing(..), tcLookupId 
49                         )
50 import TcRules          ( tcIfaceRules, tcSourceRules )
51 import TcForeign        ( tcForeignImports, tcForeignExports )
52 import TcIfaceSig       ( tcInterfaceSigs )
53 import TcInstDcls       ( tcInstDecls1, tcInstDecls2 )
54 import TcSimplify       ( tcSimplifyTop, tcSimplifyInfer )
55 import TcTyClsDecls     ( tcTyAndClassDecls )
56 import CoreUnfold       ( unfoldingTemplate, hasUnfolding )
57 import TysWiredIn       ( mkListTy, unitTy )
58 import ErrUtils         ( printErrorsAndWarnings, errorsFound, 
59                           dumpIfSet_dyn, dumpIfSet_dyn_or, showPass )
60 import Id               ( Id, idType, idUnfolding )
61 import Module           ( Module, moduleName )
62 import Name             ( Name )
63 import NameEnv          ( nameEnvElts, lookupNameEnv )
64 import TyCon            ( tyConGenInfo )
65 import BasicTypes       ( EP(..), Fixity, RecFlag(..) )
66 import SrcLoc           ( noSrcLoc )
67 import Outputable
68 import IO               ( stdout )
69 import HscTypes         ( PersistentCompilerState(..), HomeSymbolTable, 
70                           PackageTypeEnv, ModIface(..),
71                           ModDetails(..), DFunId,
72                           TypeEnv, extendTypeEnvList, 
73                           TyThing(..), implicitTyThingIds, 
74                           mkTypeEnv
75                         )
76 \end{code}
77
78
79 %************************************************************************
80 %*                                                                      *
81 \subsection{The stmt interface}
82 %*                                                                      *
83 %************************************************************************
84
85 \begin{code}
86 typecheckStmt
87    :: DynFlags
88    -> PersistentCompilerState
89    -> HomeSymbolTable
90    -> TypeEnv              -- The interactive context's type envt 
91    -> PrintUnqualified     -- For error printing
92    -> Module               -- Is this really needed
93    -> [Name]               -- Names bound by the Stmt (empty for expressions)
94    -> (SyntaxMap,
95        RenamedStmt,        -- The stmt itself
96        [RenamedHsDecl])    -- Plus extra decls it sucked in from interface files
97    -> IO (Maybe (PersistentCompilerState, 
98                  TypecheckedHsExpr, 
99                  [Id],
100                  Type))
101                 -- The returned [Id] is the same as the input except for
102                 -- ExprStmt, in which case the returned [Name] is [itName]
103
104 typecheckStmt dflags pcs hst ic_type_env unqual this_mod names (syn_map, stmt, iface_decls)
105   = typecheck dflags syn_map pcs hst unqual $
106
107          -- use the default default settings, i.e. [Integer, Double]
108     tcSetDefaultTys defaultDefaultTys $
109
110         -- Typecheck the extra declarations
111     fixTc (\ ~(unf_env, _, _, _, _) ->
112         tcImports unf_env pcs hst get_fixity this_mod iface_decls
113     )                   `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
114     ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules )
115
116     tcSetEnv env                                $
117     tcExtendGlobalTypeEnv ic_type_env           $
118
119         -- The real work is done here
120     tcUserStmt names stmt               `thenTc` \ (expr, bound_ids) ->
121
122     traceTc (text "tcs 1") `thenNF_Tc_`
123     zonkExpr expr                       `thenNF_Tc` \ zonked_expr ->
124     mapNF_Tc zonkIdBndr bound_ids       `thenNF_Tc` \ zonked_ids ->
125
126     ioToTc (dumpIfSet_dyn dflags Opt_D_dump_tc "Bound Ids" (vcat (map ppr zonked_ids))) `thenNF_Tc_`
127     ioToTc (dumpIfSet_dyn dflags Opt_D_dump_tc "Typechecked" (ppr zonked_expr))         `thenNF_Tc_`
128
129     returnTc (new_pcs, zonked_expr, zonked_ids, error "typecheckStmt: no type")
130
131   where
132     get_fixity :: Name -> Maybe Fixity
133     get_fixity n = pprPanic "typecheckStmt" (ppr n)
134 \end{code}
135
136 Here is the grand plan, implemented in tcUserStmt
137
138         What you type                   The IO [HValue] that hscStmt returns
139         -------------                   ------------------------------------
140         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
141                                         bindings: [x,y,...]
142
143         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
144                                         bindings: [x,y,...]
145
146         expr (of IO type)       ==>     expr >>= \ v -> return [v]
147           [NB: result not printed]      bindings: [it]
148           
149
150         expr (of non-IO type, 
151           result showable)      ==>     let v = expr in print v >> return [v]
152                                         bindings: [it]
153
154         expr (of non-IO type, 
155           result not showable)  ==>     error
156
157
158 \begin{code}
159 tcUserStmt :: [Name] -> RenamedStmt -> TcM (TypecheckedHsExpr, [Id])
160
161 tcUserStmt names (ExprStmt expr _ loc)
162   = ASSERT( null names )
163     tcGetUnique                 `thenNF_Tc` \ uniq ->
164     let 
165         fresh_it = itName uniq
166         the_bind = FunMonoBind fresh_it False 
167                         [ mkSimpleMatch [] expr placeHolderType loc ] loc
168     in
169     tryTc_ (traceTc (text "tcs 1b") `thenNF_Tc_`
170                 tc_stmts [fresh_it] [
171                     LetStmt (MonoBind the_bind [] NonRecursive),
172                     ExprStmt (HsApp (HsVar printName) (HsVar fresh_it)) placeHolderType loc])
173            (    traceTc (text "tcs 1a") `thenNF_Tc_`
174                 tc_stmts [fresh_it] [BindStmt (VarPatIn fresh_it) expr loc])
175
176 tcUserStmt names stmt
177   = tc_stmts names [stmt]
178     
179
180 tc_stmts names stmts
181   = tcLookupGlobalId returnIOName       `thenNF_Tc` \ return_id ->
182     tcLookupGlobalId bindIOName         `thenNF_Tc` \ bind_id ->
183     tcLookupGlobalId failIOName         `thenNF_Tc` \ fail_id ->
184     tcLookupTyCon ioTyConName           `thenNF_Tc` \ ioTyCon ->
185     newTyVarTy liftedTypeKind           `thenNF_Tc` \ res_ty ->
186     let
187         io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty)
188
189                 -- mk_return builds the expression
190                 --      returnIO @ [()] [coerce () x, ..,  coerce () z]
191         mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy]) 
192                               (ExplicitList unitTy (map mk_item ids))
193
194         mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy])
195                            (HsVar id)
196     in
197
198     traceTc (text "tcs 2") `thenNF_Tc_`
199     tcStmtsAndThen combine (DoCtxt DoExpr) io_ty stmts  (
200         -- Look up the names right in the middle,
201         -- where they will all be in scope
202         mapNF_Tc tcLookupId names                       `thenNF_Tc` \ ids ->
203         returnTc ((ids, [ResultStmt (mk_return ids) noSrcLoc]), emptyLIE)
204     )                                                   `thenTc` \ ((ids, tc_stmts), lie) ->
205
206         -- Simplify the context right here, so that we fail
207         -- if there aren't enough instances.  Notably, when we see
208         --              e
209         -- we use tryTc_ to try         it <- e
210         -- and then                     let it = e
211         -- It's the simplify step that rejects the first.
212
213     traceTc (text "tcs 3") `thenNF_Tc_`
214     tcSimplifyTop lie                   `thenTc` \ const_binds ->
215     traceTc (text "tcs 4") `thenNF_Tc_`
216
217     returnTc (mkHsLet const_binds $
218               HsDoOut DoExpr tc_stmts return_id bind_id fail_id 
219                       (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc,
220               ids)
221   where
222     combine stmt (ids, stmts) = (ids, stmt:stmts)
223 \end{code}
224
225 %************************************************************************
226 %*                                                                      *
227 \subsection{Typechecking an expression}
228 %*                                                                      *
229 %************************************************************************
230
231 \begin{code}
232 typecheckExpr :: DynFlags
233               -> PersistentCompilerState
234               -> HomeSymbolTable
235               -> TypeEnv           -- The interactive context's type envt 
236               -> PrintUnqualified       -- For error printing
237               -> Module
238               -> (SyntaxMap,
239                   RenamedHsExpr,        -- The expression itself
240                   [RenamedHsDecl])      -- Plus extra decls it sucked in from interface files
241               -> IO (Maybe (PersistentCompilerState, 
242                             TypecheckedHsExpr, 
243                             [Id],       -- always empty (matches typecheckStmt)
244                             Type))
245
246 typecheckExpr dflags pcs hst ic_type_env unqual this_mod (syn_map, expr, decls)
247   = typecheck dflags syn_map pcs hst unqual $
248
249          -- use the default default settings, i.e. [Integer, Double]
250     tcSetDefaultTys defaultDefaultTys $
251
252         -- Typecheck the extra declarations
253     fixTc (\ ~(unf_env, _, _, _, _) ->
254         tcImports unf_env pcs hst get_fixity this_mod decls
255     )                   `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
256     ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules )
257
258         -- Now typecheck the expression
259     tcSetEnv env                        $
260     tcExtendGlobalTypeEnv ic_type_env   $
261
262     newTyVarTy openTypeKind             `thenTc` \ ty ->
263     tcMonoExpr expr ty                  `thenTc` \ (e', lie) ->
264     tcSimplifyInfer smpl_doc (tyVarsOfType ty) lie 
265                                         `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) ->
266     tcSimplifyTop lie_free              `thenTc` \ const_binds ->
267
268     let all_expr = mkHsLet const_binds  $
269                    TyLam qtvs           $
270                    DictLam dict_ids     $
271                    mkHsLet dict_binds   $       
272                    e'
273
274         all_expr_ty = mkForAllTys qtvs  $
275                       mkFunTys (map idType dict_ids) $
276                       ty
277     in
278
279     zonkExpr all_expr                           `thenNF_Tc` \ zonked_expr ->
280     zonkTcType all_expr_ty                      `thenNF_Tc` \ zonked_ty ->
281     ioToTc (dumpIfSet_dyn dflags 
282                 Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_`
283     returnTc (new_pcs, zonked_expr, [], zonked_ty) 
284
285   where
286     get_fixity :: Name -> Maybe Fixity
287     get_fixity n = pprPanic "typecheckExpr" (ppr n)
288
289     smpl_doc = ptext SLIT("main expression")
290 \end{code}
291
292 %************************************************************************
293 %*                                                                      *
294 \subsection{Typechecking a module}
295 %*                                                                      *
296 %************************************************************************
297
298 \begin{code}
299 typecheckModule
300         :: DynFlags
301         -> PersistentCompilerState
302         -> HomeSymbolTable
303         -> ModIface             -- Iface for this module
304         -> PrintUnqualified     -- For error printing
305         -> (SyntaxMap, [RenamedHsDecl])
306         -> IO (Maybe (PersistentCompilerState, TcResults))
307                         -- The new PCS is Augmented with imported information,
308                                                 -- (but not stuff from this module)
309
310 data TcResults
311   = TcResults {
312         -- All these fields have info *just for this module*
313         tc_env     :: TypeEnv,                  -- The top level TypeEnv
314         tc_insts   :: [DFunId],                 -- Instances 
315         tc_rules   :: [TypecheckedRuleDecl],    -- Transformation rules
316         tc_binds   :: TypecheckedMonoBinds,     -- Bindings
317         tc_fords   :: [TypecheckedForeignDecl]  -- Foreign import & exports.
318     }
319
320
321 typecheckModule dflags pcs hst mod_iface unqual (syn_map, decls)
322   = do  { maybe_tc_result <- typecheck dflags syn_map pcs hst unqual $
323                              tcModule pcs hst get_fixity this_mod decls
324         ; printTcDump dflags unqual maybe_tc_result
325         ; return maybe_tc_result }
326   where
327     this_mod   = mi_module   mod_iface
328     fixity_env = mi_fixities mod_iface
329
330     get_fixity :: Name -> Maybe Fixity
331     get_fixity nm = lookupNameEnv fixity_env nm
332
333
334 tcModule :: PersistentCompilerState
335          -> HomeSymbolTable
336          -> (Name -> Maybe Fixity)
337          -> Module
338          -> [RenamedHsDecl]
339          -> TcM (PersistentCompilerState, TcResults)
340
341 tcModule pcs hst get_fixity this_mod decls
342   = fixTc (\ ~(unf_env, _, _) ->
343                 -- Loop back the final environment, including the fully zonked
344                 -- versions of bindings from this module.  In the presence of mutual
345                 -- recursion, interface type signatures may mention variables defined
346                 -- in this module, which is why the knot is so big
347
348                 -- Type-check the type and class decls, and all imported decls
349         tcImports unf_env pcs hst get_fixity this_mod decls     
350                                 `thenTc` \ (env, new_pcs, local_insts, deriv_binds, local_rules) ->
351
352         tcSetEnv env                            $
353
354         -- Foreign import declarations next
355         traceTc (text "Tc4")                    `thenNF_Tc_`
356         tcForeignImports decls                  `thenTc`    \ (fo_ids, foi_decls) ->
357         tcExtendGlobalValEnv fo_ids             $
358     
359         -- Default declarations
360         tcDefaults decls                        `thenTc` \ defaulting_tys ->
361         tcSetDefaultTys defaulting_tys          $
362         
363         -- Value declarations next.
364         -- We also typecheck any extra binds that came out of the "deriving" process
365         traceTc (text "Default types" <+> ppr defaulting_tys)   `thenNF_Tc_`
366         traceTc (text "Tc5")                            `thenNF_Tc_`
367         tcTopBinds (val_binds `ThenBinds` deriv_binds)  `thenTc` \ ((val_binds, env), lie_valdecls) ->
368         
369         -- Second pass over class and instance declarations, 
370         -- plus rules and foreign exports, to generate bindings
371         tcSetEnv env                            $
372         tcInstDecls2  local_insts               `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
373         tcClassDecls2 this_mod tycl_decls       `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
374         tcForeignExports decls                  `thenTc`    \ (lie_fodecls,   foe_binds, foe_decls) ->
375         tcSourceRules source_rules              `thenNF_Tc` \ (lie_rules,     more_local_rules) ->
376         
377                 -- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED
378         traceTc (text "Tc6")                    `thenNF_Tc_`
379         tcCheckMain this_mod                    `thenTc_`
380
381              -- Deal with constant or ambiguous InstIds.  How could
382              -- there be ambiguous ones?  They can only arise if a
383              -- top-level decl falls under the monomorphism
384              -- restriction, and no subsequent decl instantiates its
385              -- type.  (Usually, ambiguous type variables are resolved
386              -- during the generalisation step.)
387              --
388              -- Note that we must do this *after* tcCheckMain, because of the
389              -- following bizarre case: 
390              --         main = return ()
391              -- Here, we infer main :: forall a. m a, where m is a free
392              -- type variable.  tcCheckMain will unify it with IO, and that
393              -- must happen before tcSimplifyTop, since the latter will report
394              -- m as ambiguous
395         let
396             lie_alldecls = lie_valdecls  `plusLIE`
397                            lie_instdecls `plusLIE`
398                            lie_clasdecls `plusLIE`
399                            lie_fodecls   `plusLIE`
400                            lie_rules
401         in
402         tcSimplifyTop lie_alldecls      `thenTc` \ const_inst_binds ->
403         traceTc (text "endsimpltop") `thenTc_`
404         
405             -- Backsubstitution.    This must be done last.
406             -- Even tcSimplifyTop may do some unification.
407         let
408             all_binds = val_binds               `AndMonoBinds`
409                             inst_binds          `AndMonoBinds`
410                             cls_dm_binds        `AndMonoBinds`
411                             const_inst_binds    `AndMonoBinds`
412                             foe_binds
413         in
414         traceTc (text "Tc7")            `thenNF_Tc_`
415         zonkTopBinds all_binds          `thenNF_Tc` \ (all_binds', final_env)  ->
416         tcSetEnv final_env              $
417                 -- zonkTopBinds puts all the top-level Ids into the tcGEnv
418         traceTc (text "Tc8")            `thenNF_Tc_`
419         zonkForeignExports foe_decls    `thenNF_Tc` \ foe_decls' ->
420         traceTc (text "Tc9")            `thenNF_Tc_`
421         zonkRules more_local_rules      `thenNF_Tc` \ more_local_rules' ->
422         
423         
424         let     local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv final_env))
425         
426                 -- Create any necessary "implicit" bindings (data constructors etc)
427                 -- Should we create bindings for dictionary constructors?
428                 -- They are always fully applied, and the bindings are just there
429                 -- to support partial applications. But it's easier to let them through.
430                 implicit_binds = andMonoBindList [ CoreMonoBind id (unfoldingTemplate unf)
431                                                  | id <- implicitTyThingIds local_things
432                                                  , let unf = idUnfolding id
433                                                  , hasUnfolding unf
434                                                  ]
435         
436                 local_type_env :: TypeEnv
437                 local_type_env = mkTypeEnv local_things
438                     
439                 all_local_rules = local_rules ++ more_local_rules'
440         in  
441         traceTc (text "Tc10")           `thenNF_Tc_`
442         returnTc (final_env,
443                   new_pcs,
444                   TcResults { tc_env     = local_type_env,
445                               tc_insts   = map iDFunId local_insts,
446                               tc_binds   = implicit_binds `AndMonoBinds` all_binds', 
447                               tc_fords   = foi_decls ++ foe_decls',
448                               tc_rules   = all_local_rules
449                             }
450         )
451     )                   `thenTc` \ (_, pcs, tc_result) ->
452     returnTc (pcs, tc_result)
453   where
454     tycl_decls   = [d | TyClD d <- decls]
455     val_binds    = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
456     source_rules = [d | RuleD d <- decls, not (isIfaceRuleDecl d)]
457 \end{code}
458
459
460 %************************************************************************
461 %*                                                                      *
462 \subsection{Typechecking interface decls}
463 %*                                                                      *
464 %************************************************************************
465
466 \begin{code}
467 typecheckIface
468         :: DynFlags
469         -> PersistentCompilerState
470         -> HomeSymbolTable
471         -> ModIface             -- Iface for this module (just module & fixities)
472         -> (SyntaxMap, [RenamedHsDecl])
473         -> IO (Maybe (PersistentCompilerState, ModDetails))
474                         -- The new PCS is Augmented with imported information,
475                         -- (but not stuff from this module).
476
477 typecheckIface dflags pcs hst mod_iface (syn_map, decls)
478   = do  { maybe_tc_stuff <- typecheck dflags syn_map pcs hst alwaysQualify $
479                             tcIfaceImports pcs hst get_fixity this_mod decls
480         ; printIfaceDump dflags maybe_tc_stuff
481         ; return maybe_tc_stuff }
482   where
483     this_mod   = mi_module   mod_iface
484     fixity_env = mi_fixities mod_iface
485
486     get_fixity :: Name -> Maybe Fixity
487     get_fixity nm = lookupNameEnv fixity_env nm
488
489     tcIfaceImports pcs hst get_fixity this_mod decls
490         = fixTc (\ ~(unf_env, _, _, _, _) ->
491               tcImports unf_env pcs hst get_fixity this_mod decls
492           )     `thenTc` \ (env, new_pcs, local_inst_info, 
493                             deriv_binds, local_rules) ->
494           ASSERT(nullBinds deriv_binds)
495           let 
496               local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv env))
497
498               mod_details = ModDetails { md_types = mkTypeEnv local_things,
499                                          md_insts = map iDFunId local_inst_info,
500                                          md_rules = [(id,rule) | IfaceRuleOut id rule <- local_rules],
501                                          md_binds = [] }
502                         -- All the rules from an interface are of the IfaceRuleOut form
503           in
504           returnTc (new_pcs, mod_details)
505
506 tcImports :: RecTcEnv
507           -> PersistentCompilerState
508           -> HomeSymbolTable
509           -> (Name -> Maybe Fixity)
510           -> Module
511           -> [RenamedHsDecl]
512           -> TcM (TcEnv, PersistentCompilerState, [InstInfo], 
513                          RenamedHsBinds, [TypecheckedRuleDecl])
514
515 -- tcImports is a slight mis-nomer.  
516 -- It deals with everything that could be an import:
517 --      type and class decls
518 --      interface signatures (checked lazily)
519 --      instance decls
520 --      rule decls
521 -- These can occur in source code too, of course
522
523 tcImports unf_env pcs hst get_fixity this_mod decls
524           -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
525           -- which is done lazily [ie failure just drops the pragma
526           -- without having any global-failure effect].
527           -- 
528           -- unf_env is also used to get the pragama info
529           -- for imported dfuns and default methods
530
531   = checkNoErrsTc $
532         -- tcImports recovers internally, but if anything gave rise to
533         -- an error we'd better stop now, to avoid a cascade
534         
535     traceTc (text "Tc1")                        `thenNF_Tc_`
536     tcTyAndClassDecls unf_env tycl_decls        `thenTc` \ env ->
537     tcSetEnv env                                $
538     
539         -- Typecheck the instance decls, includes deriving
540     traceTc (text "Tc2")        `thenNF_Tc_`
541     tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs) 
542              hst unf_env get_fixity this_mod 
543              decls                      `thenTc` \ (new_pcs_insts, inst_env, local_insts, deriv_binds) ->
544     tcSetInstEnv inst_env                       $
545     
546     -- Interface type signatures
547     -- We tie a knot so that the Ids read out of interfaces are in scope
548     --   when we read their pragmas.
549     -- What we rely on is that pragmas are typechecked lazily; if
550     --   any type errors are found (ie there's an inconsistency)
551     --   we silently discard the pragma
552     traceTc (text "Tc3")                        `thenNF_Tc_`
553     tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
554     tcExtendGlobalValEnv sig_ids                $
555     
556     
557     tcIfaceRules (pcs_rules pcs) this_mod iface_rules   `thenNF_Tc` \ (new_pcs_rules, local_rules) ->
558         -- When relinking this module from its interface-file decls
559         -- we'll have IfaceRules that are in fact local to this module
560         -- That's the reason we we get any local_rules out here
561     
562     tcGetEnv                                            `thenTc` \ unf_env ->
563     let
564         all_things = nameEnvElts (getTcGEnv unf_env)
565     
566          -- sometimes we're compiling in the context of a package module
567          -- (on the GHCi command line, for example).  In this case, we
568          -- want to treat everything we pulled in as an imported thing.
569         imported_things
570           = filter (not . isLocalThing this_mod) all_things
571         
572         new_pte :: PackageTypeEnv
573         new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
574         
575         new_pcs :: PersistentCompilerState
576         new_pcs = pcs { pcs_PTE   = new_pte,
577                         pcs_insts = new_pcs_insts,
578                         pcs_rules = new_pcs_rules
579                   }
580     in
581     returnTc (unf_env, new_pcs, local_insts, deriv_binds, local_rules)
582   where
583     tycl_decls  = [d | TyClD d <- decls]
584     iface_rules = [d | RuleD d <- decls, isIfaceRuleDecl d]
585 \end{code}    
586
587
588 %************************************************************************
589 %*                                                                      *
590 \subsection{Checking the type of main}
591 %*                                                                      *
592 %************************************************************************
593
594 We must check that in module Main,
595         a) main is defined
596         b) main :: forall a1...an. IO t,  for some type t
597
598 If we have
599         main = error "Urk"
600 then the type of main will be 
601         main :: forall a. a
602 and that should pass the test too.  
603
604 So we just instantiate the type and unify with IO t, and declare 
605 victory if doing so succeeds.
606
607 \begin{code}
608 tcCheckMain :: Module -> TcM ()
609 tcCheckMain this_mod
610   | not (moduleName this_mod == mAIN_Name )
611   = returnTc ()
612
613   | otherwise
614   =     -- First unify the main_id with IO t, for any old t
615     tcLookup_maybe mainName             `thenNF_Tc` \ maybe_thing ->
616     case maybe_thing of
617         Just (ATcId main_id) -> check_main_ty (idType main_id)
618         other                -> addErrTc noMainErr      
619   where
620     check_main_ty main_ty
621       = tcInstType main_ty              `thenNF_Tc` \ (tvs, theta, main_tau) ->
622         newTyVarTy liftedTypeKind       `thenNF_Tc` \ arg_ty ->
623         tcLookupTyCon ioTyConName       `thenNF_Tc` \ ioTyCon ->
624         tcAddErrCtxtM (mainTypeCtxt main_ty)    $
625         if not (null theta) then 
626                 failWithTc empty        -- Context has the error message
627         else
628         unifyTauTy main_tau (mkTyConApp ioTyCon [arg_ty])
629
630 mainTypeCtxt main_ty tidy_env 
631   = zonkTcType main_ty          `thenNF_Tc` \ main_ty' ->
632     returnNF_Tc (tidy_env, ptext SLIT("`main' has the illegal type") <+> 
633                                  quotes (ppr (tidyType tidy_env main_ty')))
634
635 noMainErr = hsep [ptext SLIT("Module") <+> quotes (ppr mAIN_Name), 
636                   ptext SLIT("must include a definition for") <+> quotes (ptext SLIT("main"))]
637 \end{code}
638
639
640 %************************************************************************
641 %*                                                                      *
642 \subsection{Interfacing the Tc monad to the IO monad}
643 %*                                                                      *
644 %************************************************************************
645
646 \begin{code}
647 typecheck :: DynFlags
648           -> SyntaxMap
649           -> PersistentCompilerState
650           -> HomeSymbolTable
651           -> PrintUnqualified   -- For error printing
652           -> TcM r
653           -> IO (Maybe r)
654
655 typecheck dflags syn_map pcs hst unqual thing_inside 
656  = do   { showPass dflags "Typechecker";
657         ; env <- initTcEnv syn_map hst (pcs_PTE pcs)
658
659         ; (maybe_tc_result, errs) <- initTc dflags env thing_inside
660
661         ; printErrorsAndWarnings unqual errs
662
663         ; if errorsFound errs then 
664              return Nothing 
665            else 
666              return maybe_tc_result
667         }
668 \end{code}
669
670
671 %************************************************************************
672 %*                                                                      *
673 \subsection{Dumping output}
674 %*                                                                      *
675 %************************************************************************
676
677 \begin{code}
678 printTcDump dflags unqual Nothing = return ()
679 printTcDump dflags unqual (Just (_, results))
680   = do if dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags then
681           printForUser stdout unqual (dump_tc_iface dflags results)
682           else return ()
683
684        dumpIfSet_dyn dflags Opt_D_dump_tc    
685                      "Typechecked" (ppr (tc_binds results))
686
687           
688 printIfaceDump dflags Nothing = return ()
689 printIfaceDump dflags (Just (_, details))
690   = dumpIfSet_dyn_or dflags [Opt_D_dump_types, Opt_D_dump_tc]
691                      "Interface" (pprModDetails details)
692
693 dump_tc_iface dflags results
694   = vcat [pprModDetails (ModDetails {md_types = tc_env results, 
695                                      md_insts = tc_insts results,
696                                      md_rules = [], md_binds = []}) ,
697           ppr_rules (tc_rules results),
698
699           if dopt Opt_Generics dflags then
700                 ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)]
701           else 
702                 empty
703     ]
704
705 ppr_rules [] = empty
706 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
707                       nest 4 (vcat (map ppr rs)),
708                       ptext SLIT("#-}")]
709
710 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
711                            vcat (map ppr_gen_tycon tcs),
712                            ptext SLIT("#-}")
713                      ]
714
715 -- x&y are now Id's, not CoreExpr's 
716 ppr_gen_tycon tycon 
717   | Just ep <- tyConGenInfo tycon
718   = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
719
720   | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
721
722 ppr_ep (EP from to)
723   = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
724            ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
725            ptext SLIT("To:")   <+> ppr (unfoldingTemplate (idUnfolding to))
726     ]
727   where
728     (_,from_tau) = tcSplitForAllTys (idType from)
729 \end{code}