[project @ 2000-11-21 16:33:18 by simonmar]
[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, typecheckExpr, TcResults(..)
9     ) where
10
11 #include "HsVersions.h"
12
13 import CmdLineOpts      ( DynFlag(..), DynFlags, opt_PprStyle_Debug )
14 import HsSyn            ( HsBinds(..), MonoBinds(..), HsDecl(..), 
15                           isIfaceRuleDecl, nullBinds, andMonoBindList
16                         )
17 import HsTypes          ( toHsType )
18 import RnHsSyn          ( RenamedHsBinds, RenamedHsDecl, RenamedHsExpr )
19 import TcHsSyn          ( TypecheckedMonoBinds, TypecheckedHsExpr,
20                           TypecheckedForeignDecl, TypecheckedRuleDecl,
21                           zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet,
22                           zonkExpr
23                         )
24
25
26 import TcMonad
27 import TcType           ( newTyVarTy, zonkTcType )
28 import Inst             ( plusLIE )
29 import TcBinds          ( tcTopBinds )
30 import TcClassDcl       ( tcClassDecls2 )
31 import TcDefaults       ( tcDefaults, defaultDefaultTys )
32 import TcExpr           ( tcMonoExpr )
33 import TcEnv            ( TcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv, 
34                           isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv
35                         )
36 import TcRules          ( tcIfaceRules, tcSourceRules )
37 import TcForeign        ( tcForeignImports, tcForeignExports )
38 import TcIfaceSig       ( tcInterfaceSigs )
39 import TcInstDcls       ( tcInstDecls1, tcInstDecls2 )
40 import TcSimplify       ( tcSimplifyTop )
41 import TcTyClsDecls     ( tcTyAndClassDecls )
42
43 import CoreUnfold       ( unfoldingTemplate, hasUnfolding )
44 import Type             ( funResultTy, splitForAllTys, openTypeKind )
45 import Bag              ( isEmptyBag )
46 import ErrUtils         ( printErrorsAndWarnings, dumpIfSet_dyn, showPass )
47 import Id               ( idType, idUnfolding )
48 import Module           ( Module )
49 import Name             ( Name, toRdrName )
50 import Name             ( nameEnvElts, lookupNameEnv )
51 import TyCon            ( tyConGenInfo )
52 import Util
53 import BasicTypes       ( EP(..), Fixity )
54 import Bag              ( isEmptyBag )
55 import Outputable
56 import HscTypes         ( PersistentCompilerState(..), HomeSymbolTable, 
57                           PackageTypeEnv, DFunId, ModIface(..),
58                           TypeEnv, extendTypeEnvList, 
59                           TyThing(..), implicitTyThingIds, 
60                           mkTypeEnv
61                         )
62 \end{code}
63
64 Outside-world interface:
65 \begin{code}
66
67 -- Convenient type synonyms first:
68 data TcResults
69   = TcResults {
70         -- All these fields have info *just for this module*
71         tc_env     :: TypeEnv,                  -- The top level TypeEnv
72         tc_insts   :: [DFunId],                 -- Instances
73         tc_binds   :: TypecheckedMonoBinds,     -- Bindings
74         tc_fords   :: [TypecheckedForeignDecl], -- Foreign import & exports.
75         tc_rules   :: [TypecheckedRuleDecl]     -- Transformation rules
76     }
77
78 ---------------
79 typecheckModule
80         :: DynFlags
81         -> PersistentCompilerState
82         -> HomeSymbolTable
83         -> ModIface             -- Iface for this module
84         -> PrintUnqualified     -- For error printing
85         -> [RenamedHsDecl]
86         -> IO (Maybe (PersistentCompilerState, TcResults))
87                         -- The new PCS is Augmented with imported information,
88                                                 -- (but not stuff from this module)
89
90
91 typecheckModule dflags pcs hst mod_iface unqual decls
92   = do  { maybe_tc_result <- typecheck dflags pcs hst unqual $
93                              tcModule pcs hst get_fixity this_mod decls
94         ; printTcDump dflags maybe_tc_result
95         ; return maybe_tc_result }
96   where
97     this_mod   = mi_module   mod_iface
98     fixity_env = mi_fixities mod_iface
99
100     get_fixity :: Name -> Maybe Fixity
101     get_fixity nm = lookupNameEnv fixity_env nm
102
103 ---------------
104 typecheckExpr :: DynFlags
105               -> PersistentCompilerState
106               -> HomeSymbolTable
107               -> PrintUnqualified       -- For error printing
108               -> Module
109               -> (RenamedHsExpr,        -- The expression itself
110                   [RenamedHsDecl])      -- Plus extra decls it sucked in from interface files
111               -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr, TcType))
112
113 typecheckExpr dflags pcs hst unqual this_mod (expr, decls)
114   = typecheck dflags pcs hst unqual $
115
116          -- use the default default settings, i.e. [Integer, Double]
117     tcSetDefaultTys defaultDefaultTys $
118     tcImports pcs hst get_fixity this_mod decls `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
119     ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules )
120
121     tcSetEnv env                                $
122     newTyVarTy openTypeKind     `thenTc` \ ty ->
123     tcMonoExpr expr ty          `thenTc` \ (expr', lie) ->
124     tcSimplifyTop lie           `thenTc` \ binds ->
125     let all_expr = mkHsLet binds expr' in
126     zonkExpr all_expr           `thenNF_Tc` \ zonked_expr ->
127     zonkTcType ty               `thenNF_Tc` \ zonked_ty ->
128     returnTc (new_pcs, zonked_expr, zonked_ty) 
129   where
130     get_fixity :: Name -> Maybe Fixity
131     get_fixity n = pprPanic "typecheckExpr" (ppr n)
132
133 ---------------
134 typecheck :: DynFlags
135           -> PersistentCompilerState
136           -> HomeSymbolTable
137           -> PrintUnqualified   -- For error printing
138           -> TcM r
139           -> IO (Maybe r)
140
141 typecheck dflags pcs hst unqual thing_inside 
142  = do   { showPass dflags "Typechecker";
143         ; env <- initTcEnv hst (pcs_PTE pcs)
144
145         ; (maybe_tc_result, (warns,errs)) <- initTc dflags env thing_inside
146
147         ; printErrorsAndWarnings unqual (errs,warns)
148
149         ; if isEmptyBag errs then 
150              return maybe_tc_result
151            else 
152              return Nothing 
153         }
154 \end{code}
155
156 The internal monster:
157 \begin{code}
158 tcModule :: PersistentCompilerState
159          -> HomeSymbolTable
160          -> (Name -> Maybe Fixity)
161          -> Module
162          -> [RenamedHsDecl]
163          -> TcM (PersistentCompilerState, TcResults)
164
165 tcModule pcs hst get_fixity this_mod decls
166   =     -- Type-check the type and class decls, and all imported decls
167     tcImports pcs hst get_fixity this_mod decls `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
168
169     tcSetEnv env                                $
170
171         -- Foreign import declarations next
172 --  traceTc (text "Tc4")                        `thenNF_Tc_`
173     tcForeignImports decls                      `thenTc`    \ (fo_ids, foi_decls) ->
174     tcExtendGlobalValEnv fo_ids                 $
175     
176         -- Default declarations
177     tcDefaults decls                            `thenTc` \ defaulting_tys ->
178     tcSetDefaultTys defaulting_tys              $
179         
180         -- Value declarations next.
181         -- We also typecheck any extra binds that came out of the "deriving" process
182 --  traceTc (text "Tc5")                                `thenNF_Tc_`
183     tcTopBinds (val_binds `ThenBinds` deriv_binds)      `thenTc` \ ((val_binds, env), lie_valdecls) ->
184     tcSetEnv env $
185     
186         -- Foreign export declarations next
187 --  traceTc (text "Tc6")                `thenNF_Tc_`
188     tcForeignExports decls              `thenTc`    \ (lie_fodecls, foe_binds, foe_decls) ->
189     
190         -- Second pass over class and instance declarations,
191         -- to compile the bindings themselves.
192     tcInstDecls2  local_inst_info               `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
193     tcClassDecls2 this_mod tycl_decls           `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
194     tcSourceRules source_rules                  `thenNF_Tc` \ (lie_rules,     more_local_rules) ->
195     
196          -- Deal with constant or ambiguous InstIds.  How could
197          -- there be ambiguous ones?  They can only arise if a
198          -- top-level decl falls under the monomorphism
199          -- restriction, and no subsequent decl instantiates its
200          -- type.  (Usually, ambiguous type variables are resolved
201          -- during the generalisation step.)
202     let
203         lie_alldecls = lie_valdecls     `plusLIE`
204                        lie_instdecls    `plusLIE`
205                        lie_clasdecls    `plusLIE`
206                        lie_fodecls      `plusLIE`
207                        lie_rules
208     in
209     tcSimplifyTop lie_alldecls                  `thenTc` \ const_inst_binds ->
210     
211         -- Backsubstitution.    This must be done last.
212         -- Even tcSimplifyTop may do some unification.
213     let
214         all_binds = val_binds           `AndMonoBinds`
215                     inst_binds          `AndMonoBinds`
216                     cls_dm_binds        `AndMonoBinds`
217                     const_inst_binds    `AndMonoBinds`
218                     foe_binds
219     in
220 --  traceTc (text "Tc9")                `thenNF_Tc_`
221     zonkTopBinds all_binds              `thenNF_Tc` \ (all_binds', final_env)  ->
222     tcSetEnv final_env                  $
223         -- zonkTopBinds puts all the top-level Ids into the tcGEnv
224     zonkForeignExports foe_decls        `thenNF_Tc` \ foe_decls' ->
225     zonkRules more_local_rules          `thenNF_Tc` \ more_local_rules' ->
226     
227     
228     let local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv final_env))
229
230         -- Create any necessary "implicit" bindings (data constructors etc)
231         -- Should we create bindings for dictionary constructors?
232         -- They are always fully applied, and the bindings are just there
233         -- to support partial applications. But it's easier to let them through.
234         implicit_binds = andMonoBindList [ CoreMonoBind id (unfoldingTemplate unf)
235                                          | id <- implicitTyThingIds local_things
236                                          , let unf = idUnfolding id
237                                          , hasUnfolding unf
238                                          ]
239
240         local_type_env :: TypeEnv
241         local_type_env = mkTypeEnv local_things
242             
243         all_local_rules = local_rules ++ more_local_rules'
244     in  
245 --  traceTc (text "Tc10")               `thenNF_Tc_`
246     returnTc (new_pcs,
247               TcResults { tc_env     = local_type_env,
248                           tc_binds   = implicit_binds `AndMonoBinds` all_binds', 
249                           tc_insts   = map iDFunId local_inst_info,
250                           tc_fords   = foi_decls ++ foe_decls',
251                           tc_rules   = all_local_rules
252                         }
253     )
254   where
255     tycl_decls   = [d | TyClD d <- decls]
256     val_binds    = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
257     source_rules = [d | RuleD d <- decls, not (isIfaceRuleDecl d)]
258 \end{code}
259
260
261 \begin{code}
262 tcImports :: PersistentCompilerState
263           -> HomeSymbolTable
264           -> (Name -> Maybe Fixity)
265           -> Module
266           -> [RenamedHsDecl]
267           -> TcM (TcEnv, PersistentCompilerState, 
268                   [InstInfo], RenamedHsBinds, [TypecheckedRuleDecl])
269
270 -- tcImports is a slight mis-nomer.  
271 -- It deals with everythign that could be an import:
272 --      type and class decls
273 --      interface signatures
274 --      instance decls
275 --      rule decls
276 -- These can occur in source code too, of course
277
278 tcImports pcs hst get_fixity this_mod decls
279   = fixTc (\ ~(unf_env, _, _, _, _) -> 
280           -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
281           -- which is done lazily [ie failure just drops the pragma
282           -- without having any global-failure effect].
283           -- 
284           -- unf_env is also used to get the pragama info
285           -- for imported dfuns and default methods
286                 
287 --      traceTc (text "Tc1")                    `thenNF_Tc_`
288         tcTyAndClassDecls unf_env tycl_decls    `thenTc` \ env ->
289         tcSetEnv env                            $
290         
291                 -- Typecheck the instance decls, includes deriving
292 --      traceTc (text "Tc2")    `thenNF_Tc_`
293         tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs) 
294                      hst unf_env get_fixity this_mod 
295                      decls                      `thenTc` \ (new_pcs_insts, inst_env, local_inst_info, deriv_binds) ->
296         tcSetInstEnv inst_env                   $
297         
298         -- Interface type signatures
299         -- We tie a knot so that the Ids read out of interfaces are in scope
300         --   when we read their pragmas.
301         -- What we rely on is that pragmas are typechecked lazily; if
302         --   any type errors are found (ie there's an inconsistency)
303         --   we silently discard the pragma
304 --      traceTc (text "Tc3")                    `thenNF_Tc_`
305         tcInterfaceSigs unf_env tycl_decls      `thenTc` \ sig_ids ->
306         tcExtendGlobalValEnv sig_ids            $
307         
308         
309         tcIfaceRules (pcs_rules pcs) this_mod iface_rules       `thenNF_Tc` \ (new_pcs_rules, local_rules) ->
310
311         tcGetEnv                                                `thenTc` \ unf_env ->
312         let
313             imported_things = filter (not . isLocalThing this_mod) (nameEnvElts (getTcGEnv unf_env))
314
315             new_pte :: PackageTypeEnv
316             new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
317             
318             new_pcs :: PersistentCompilerState
319             new_pcs = pcs { pcs_PTE   = new_pte,
320                             pcs_insts = new_pcs_insts,
321                             pcs_rules = new_pcs_rules
322                       }
323         in
324         returnTc (unf_env, new_pcs, local_inst_info, deriv_binds, local_rules)
325     )
326   where
327     tycl_decls  = [d | TyClD d <- decls]
328     iface_rules = [d | RuleD d <- decls, isIfaceRuleDecl d]
329 \end{code}    
330
331 %************************************************************************
332 %*                                                                      *
333 \subsection{Dumping output}
334 %*                                                                      *
335 %************************************************************************
336
337 \begin{code}
338 printTcDump dflags Nothing = return ()
339 printTcDump dflags (Just (_, results))
340   = do dumpIfSet_dyn dflags Opt_D_dump_types 
341                      "Type signatures" (dump_sigs results)
342        dumpIfSet_dyn dflags Opt_D_dump_tc    
343                      "Typechecked" (dump_tc results) 
344
345 dump_tc results
346   = vcat [ppr (tc_binds results),
347           pp_rules (tc_rules results),
348           ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)]
349     ]
350
351 dump_sigs results       -- Print type signatures
352   =     -- Convert to HsType so that we get source-language style printing
353         -- And sort by RdrName
354     vcat $ map ppr_sig $ sortLt lt_sig $
355     [ (toRdrName id, toHsType (idType id))
356     | AnId id <- nameEnvElts (tc_env results),
357       want_sig id
358     ]
359   where
360     lt_sig (n1,_) (n2,_) = n1 < n2
361     ppr_sig (n,t)        = ppr n <+> dcolon <+> ppr t
362
363     want_sig id | opt_PprStyle_Debug = True
364                 | otherwise          = True     -- For now
365
366 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
367                            vcat (map ppr_gen_tycon tcs),
368                            ptext SLIT("#-}")
369                      ]
370
371 -- x&y are now Id's, not CoreExpr's 
372 ppr_gen_tycon tycon 
373   | Just ep <- tyConGenInfo tycon
374   = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
375
376   | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
377
378 ppr_ep (EP from to)
379   = vcat [ ptext SLIT("Rep type:") <+> ppr (funResultTy from_tau),
380            ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
381            ptext SLIT("To:")   <+> ppr (unfoldingTemplate (idUnfolding to))
382     ]
383   where
384     (_,from_tau) = splitForAllTys (idType from)
385
386 pp_rules [] = empty
387 pp_rules rs = vcat [ptext SLIT("{-# RULES"),
388                     nest 4 (vcat (map ppr rs)),
389                     ptext SLIT("#-}")]
390 \end{code}