Remove the DocEntity type. Fixes the problem with duplicate error messages at
[ghc.git] / compiler / rename / RnSource.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[RnSource]{Main pass of renamer}
5
6 \begin{code}
7 module RnSource ( 
8         rnSrcDecls, addTcgDUs, 
9         rnTyClDecls, checkModDeprec,
10         rnSplice, checkTH
11     ) where
12
13 #include "HsVersions.h"
14
15 import {-# SOURCE #-} RnExpr( rnLExpr )
16
17 import HsSyn
18 import RdrName          ( RdrName, isRdrDataCon, elemLocalRdrEnv, 
19                           globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE )
20 import RdrHsSyn         ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
21 import RnHsSyn
22 import RnTypes          ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
23 import RnBinds          ( rnTopBinds, rnMethodBinds, renameSigs, mkSigTvFn )
24 import RnEnv            ( lookupLocalDataTcNames,
25                           lookupLocatedTopBndrRn, lookupLocatedOccRn,
26                           lookupOccRn, lookupTopBndrRn, newLocalsRn, 
27                           bindLocatedLocalsFV, bindPatSigTyVarsFV,
28                           bindTyVarsRn, extendTyVarEnvFVRn,
29                           bindLocalNames, checkDupNames, mapFvRn
30                         )
31 import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
32 import TcRnMonad
33
34 import HscTypes         ( FixityEnv, FixItem(..),
35                           Deprecations, Deprecs(..), DeprecTxt, plusDeprecs )
36 import Class            ( FunDep )
37 import Name             ( Name, nameOccName )
38 import NameSet
39 import NameEnv
40 import OccName          ( occEnvElts )
41 import Outputable
42 import SrcLoc           ( Located(..), unLoc, noLoc )
43 import DynFlags ( DynFlag(..) )
44 import Maybes           ( seqMaybe )
45 import Maybe            ( isNothing, isJust )
46 import Monad            ( liftM, when )
47 import BasicTypes       ( Boxity(..) )
48 \end{code}
49
50 @rnSourceDecl@ `renames' declarations.
51 It simultaneously performs dependency analysis and precedence parsing.
52 It also does the following error checks:
53 \begin{enumerate}
54 \item
55 Checks that tyvars are used properly. This includes checking
56 for undefined tyvars, and tyvars in contexts that are ambiguous.
57 (Some of this checking has now been moved to module @TcMonoType@,
58 since we don't have functional dependency information at this point.)
59 \item
60 Checks that all variable occurences are defined.
61 \item 
62 Checks the @(..)@ etc constraints in the export list.
63 \end{enumerate}
64
65
66 \begin{code}
67 rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
68
69 rnSrcDecls (HsGroup { hs_valds  = val_decls,
70                       hs_tyclds = tycl_decls,
71                       hs_instds = inst_decls,
72                       hs_derivds = deriv_decls,
73                       hs_fixds  = fix_decls,
74                       hs_depds  = deprec_decls,
75                       hs_fords  = foreign_decls,
76                       hs_defds  = default_decls,
77                       hs_ruleds = rule_decls,
78           hs_docs   = docs })
79
80  = do {         -- Deal with deprecations (returns only the extra deprecations)
81         deprecs <- rnSrcDeprecDecls deprec_decls ;
82         updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs })
83                   $ do {
84
85                 -- Deal with top-level fixity decls 
86                 -- (returns the total new fixity env)
87         rn_fix_decls <- rnSrcFixityDecls fix_decls ;
88         fix_env <- rnSrcFixityDeclsEnv rn_fix_decls ;
89         updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env })
90                   $ do {
91
92                 -- Rename other declarations
93         traceRn (text "Start rnmono") ;
94         (rn_val_decls, bind_dus) <- rnTopBinds val_decls ;
95         traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
96
97                 -- You might think that we could build proper def/use information
98                 -- for type and class declarations, but they can be involved
99                 -- in mutual recursion across modules, and we only do the SCC
100                 -- analysis for them in the type checker.
101                 -- So we content ourselves with gathering uses only; that
102                 -- means we'll only report a declaration as unused if it isn't
103                 -- mentioned at all.  Ah well.
104         traceRn (text "Start rnTyClDecls") ;
105         (rn_tycl_decls,    src_fvs1)
106            <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ;
107         traceRn (text "finish rnTyClDecls") ;
108         (rn_inst_decls,    src_fvs2)
109            <- mapFvRn (wrapLocFstM rnSrcInstDecl) inst_decls ;
110         (rn_deriv_decls,    src_fvs_deriv)
111            <- mapFvRn (wrapLocFstM rnSrcDerivDecl) deriv_decls ;
112         (rn_rule_decls,    src_fvs3)
113            <- mapFvRn (wrapLocFstM rnHsRuleDecl) rule_decls ;
114         (rn_foreign_decls, src_fvs4)
115            <- mapFvRn (wrapLocFstM rnHsForeignDecl) foreign_decls ;
116         (rn_default_decls, src_fvs5)
117            <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ;
118
119   -- Haddock docs
120         rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
121
122         let {
123            rn_group = HsGroup { hs_valds  = rn_val_decls,
124                                 hs_tyclds = rn_tycl_decls,
125                                 hs_instds = rn_inst_decls,
126                                 hs_derivds = rn_deriv_decls,
127                                 hs_fixds  = rn_fix_decls,
128                                 hs_depds  = [],
129                                 hs_fords  = rn_foreign_decls,
130                                 hs_defds  = rn_default_decls,
131                                 hs_ruleds = rn_rule_decls,
132             hs_docs   = rn_docs } ;
133
134            other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs_deriv, src_fvs3, 
135                                 src_fvs4, src_fvs5] ;
136            src_dus = bind_dus `plusDU` usesOnly other_fvs 
137                 -- Note: src_dus will contain *uses* for locally-defined types
138                 -- and classes, but no *defs* for them.  (Because rnTyClDecl 
139                 -- returns only the uses.)  This is a little 
140                 -- surprising but it doesn't actually matter at all.
141         } ;
142
143         traceRn (text "finish rnSrc" <+> ppr rn_group) ;
144         traceRn (text "finish Dus" <+> ppr src_dus ) ;
145         tcg_env <- getGblEnv ;
146         return (tcg_env `addTcgDUs` src_dus, rn_group)
147     }}}
148
149 rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
150 rnTyClDecls tycl_decls = do 
151   (decls', fvs) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls
152   return decls'
153
154 addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv 
155 addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
156 \end{code}
157
158
159 %*********************************************************
160 %*                                                       *
161         HsDoc stuff
162 %*                                                       *
163 %*********************************************************
164
165 \begin{code}
166 rnDocDecl :: DocDecl RdrName -> RnM (DocDecl Name)
167 rnDocDecl (DocCommentNext doc) = do 
168   rn_doc <- rnHsDoc doc
169   return (DocCommentNext rn_doc)
170 rnDocDecl (DocCommentPrev doc) = do 
171   rn_doc <- rnHsDoc doc
172   return (DocCommentPrev rn_doc)
173 rnDocDecl (DocCommentNamed str doc) = do
174   rn_doc <- rnHsDoc doc
175   return (DocCommentNamed str rn_doc)
176 rnDocDecl (DocGroup lev doc) = do
177   rn_doc <- rnHsDoc doc
178   return (DocGroup lev rn_doc)
179 \end{code}
180
181
182 %*********************************************************
183 %*                                                       *
184         Source-code fixity declarations
185 %*                                                       *
186 %*********************************************************
187
188 \begin{code}
189 rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM [LFixitySig Name]
190 rnSrcFixityDecls fix_decls
191     = do fix_decls <- mapM rnFixityDecl fix_decls
192          return (concat fix_decls)
193
194 rnFixityDecl :: LFixitySig RdrName -> RnM [LFixitySig Name]
195 rnFixityDecl (L loc (FixitySig (L nameLoc rdr_name) fixity))
196     = setSrcSpan nameLoc $
197         -- GHC extension: look up both the tycon and data con 
198         -- for con-like things
199         -- If neither are in scope, report an error; otherwise
200         -- add both to the fixity env
201       do names <- lookupLocalDataTcNames rdr_name
202          return [ L loc (FixitySig (L nameLoc name) fixity)
203                       | name <- names ]
204
205 rnSrcFixityDeclsEnv :: [LFixitySig Name] -> RnM FixityEnv
206 rnSrcFixityDeclsEnv fix_decls
207   = getGblEnv                                   `thenM` \ gbl_env ->
208     foldlM rnFixityDeclEnv (tcg_fix_env gbl_env) 
209             fix_decls                                   `thenM` \ fix_env ->
210     traceRn (text "fixity env" <+> pprFixEnv fix_env)   `thenM_`
211     returnM fix_env
212
213 rnFixityDeclEnv :: FixityEnv -> LFixitySig Name -> RnM FixityEnv
214 rnFixityDeclEnv fix_env (L loc (FixitySig (L nameLoc name) fixity))
215   = case lookupNameEnv fix_env name of
216       Just (FixItem _ _ loc') 
217           -> do addLocErr (L nameLoc name) (dupFixityDecl loc')
218                 return fix_env
219       Nothing
220           -> return (extendNameEnv fix_env name fix_item)
221     where fix_item = FixItem (nameOccName name) fixity nameLoc
222
223 pprFixEnv :: FixityEnv -> SDoc
224 pprFixEnv env 
225   = pprWithCommas (\ (FixItem n f _) -> ppr f <+> ppr n)
226                   (nameEnvElts env)
227
228 dupFixityDecl loc rdr_name
229   = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
230           ptext SLIT("also at ") <+> ppr loc
231         ]
232 \end{code}
233
234
235 %*********************************************************
236 %*                                                       *
237         Source-code deprecations declarations
238 %*                                                       *
239 %*********************************************************
240
241 For deprecations, all we do is check that the names are in scope.
242 It's only imported deprecations, dealt with in RnIfaces, that we
243 gather them together.
244
245 \begin{code}
246 rnSrcDeprecDecls :: [LDeprecDecl RdrName] -> RnM Deprecations
247 rnSrcDeprecDecls [] 
248   = returnM NoDeprecs
249
250 rnSrcDeprecDecls decls
251   = mappM (addLocM rn_deprec) decls     `thenM` \ pairs_s ->
252     returnM (DeprecSome (mkNameEnv (concat pairs_s)))
253  where
254    rn_deprec (Deprecation rdr_name txt)
255      = lookupLocalDataTcNames rdr_name  `thenM` \ names ->
256        returnM [(name, (nameOccName name, txt)) | name <- names]
257
258 checkModDeprec :: Maybe DeprecTxt -> Deprecations
259 -- Check for a module deprecation; done once at top level
260 checkModDeprec Nothing    = NoDeprecs
261 checkModDeprec (Just txt) = DeprecAll txt
262 \end{code}
263
264 %*********************************************************
265 %*                                                      *
266 \subsection{Source code declarations}
267 %*                                                      *
268 %*********************************************************
269
270 \begin{code}
271 rnDefaultDecl (DefaultDecl tys)
272   = mapFvRn (rnHsTypeFVs doc_str) tys   `thenM` \ (tys', fvs) ->
273     returnM (DefaultDecl tys', fvs)
274   where
275     doc_str = text "In a `default' declaration"
276 \end{code}
277
278 %*********************************************************
279 %*                                                      *
280 \subsection{Foreign declarations}
281 %*                                                      *
282 %*********************************************************
283
284 \begin{code}
285 rnHsForeignDecl (ForeignImport name ty spec)
286   = lookupLocatedTopBndrRn name         `thenM` \ name' ->
287     rnHsTypeFVs (fo_decl_msg name) ty   `thenM` \ (ty', fvs) ->
288     returnM (ForeignImport name' ty' spec, fvs)
289
290 rnHsForeignDecl (ForeignExport name ty spec)
291   = lookupLocatedOccRn name             `thenM` \ name' ->
292     rnHsTypeFVs (fo_decl_msg name) ty   `thenM` \ (ty', fvs) ->
293     returnM (ForeignExport name' ty' spec, fvs )
294         -- NB: a foreign export is an *occurrence site* for name, so 
295         --     we add it to the free-variable list.  It might, for example,
296         --     be imported from another module
297
298 fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name
299 \end{code}
300
301
302 %*********************************************************
303 %*                                                      *
304 \subsection{Instance declarations}
305 %*                                                      *
306 %*********************************************************
307
308 \begin{code}
309 rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
310         -- Used for both source and interface file decls
311   = rnHsSigType (text "an instance decl") inst_ty       `thenM` \ inst_ty' ->
312
313         -- Rename the associated types
314         -- The typechecker (not the renamer) checks that all 
315         -- the declarations are for the right class
316     let
317         at_doc   = text "In the associated types of an instance declaration"
318         at_names = map (head . tyClDeclNames . unLoc) ats
319     in
320     checkDupNames at_doc at_names               `thenM_`
321     rnATInsts ats                               `thenM` \ (ats', at_fvs) ->
322
323         -- Rename the bindings
324         -- The typechecker (not the renamer) checks that all 
325         -- the bindings are for the right class
326     let
327         meth_doc    = text "In the bindings in an instance declaration"
328         meth_names  = collectHsBindLocatedBinders mbinds
329         (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
330     in
331     checkDupNames meth_doc meth_names   `thenM_`
332     extendTyVarEnvForMethodBinds inst_tyvars (          
333         -- (Slightly strangely) the forall-d tyvars scope over
334         -- the method bindings too
335         rnMethodBinds cls (\n->[])      -- No scoped tyvars
336                       [] mbinds
337     )                                           `thenM` \ (mbinds', meth_fvs) ->
338         -- Rename the prags and signatures.
339         -- Note that the type variables are not in scope here,
340         -- so that      instance Eq a => Eq (T a) where
341         --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
342         -- works OK. 
343         --
344         -- But the (unqualified) method names are in scope
345     let 
346         binders = collectHsBindBinders mbinds'
347         ok_sig  = okInstDclSig (mkNameSet binders)
348     in
349     bindLocalNames binders (renameSigs ok_sig uprags)   `thenM` \ uprags' ->
350
351     returnM (InstDecl inst_ty' mbinds' uprags' ats',
352              meth_fvs `plusFV` at_fvs
353                       `plusFV` hsSigsFVs uprags'
354                       `plusFV` extractHsTyNames inst_ty')
355              -- We return the renamed associated data type declarations so
356              -- that they can be entered into the list of type declarations
357              -- for the binding group, but we also keep a copy in the instance.
358              -- The latter is needed for well-formedness checks in the type
359              -- checker (eg, to ensure that all ATs of the instance actually
360              -- receive a declaration). 
361              -- NB: Even the copies in the instance declaration carry copies of
362              --     the instance context after renaming.  This is a bit
363              --     strange, but should not matter (and it would be more work
364              --     to remove the context).
365 \end{code}
366
367 Renaming of the associated types in instances.  
368
369 \begin{code}
370 rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
371 rnATInsts atDecls = 
372   mapFvRn (wrapLocFstM rnATInst) atDecls
373   where
374     rnATInst tydecl@TyData     {} = rnTyClDecl tydecl
375     rnATInst tydecl@TySynonym  {} = rnTyClDecl tydecl
376     rnATInst tydecl               =
377       pprPanic "RnSource.rnATInsts: invalid AT instance" 
378                (ppr (tcdName tydecl))
379 \end{code}
380
381 For the method bindings in class and instance decls, we extend the 
382 type variable environment iff -fglasgow-exts
383
384 \begin{code}
385 extendTyVarEnvForMethodBinds tyvars thing_inside
386   = doptM Opt_GlasgowExts                       `thenM` \ opt_GlasgowExts ->
387     if opt_GlasgowExts then
388         extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
389     else
390         thing_inside
391 \end{code}
392
393 %*********************************************************
394 %*                                                      *
395 \subsection{Stand-alone deriving declarations}
396 %*                                                      *
397 %*********************************************************
398
399 \begin{code}
400 rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
401 rnSrcDerivDecl (DerivDecl ty)
402   = do ty' <- rnLHsType (text "a deriving decl") ty
403        let fvs = extractHsTyNames ty'
404        return (DerivDecl ty', fvs)
405 \end{code}
406
407 %*********************************************************
408 %*                                                      *
409 \subsection{Rules}
410 %*                                                      *
411 %*********************************************************
412
413 \begin{code}
414 rnHsRuleDecl (HsRule rule_name act vars lhs fv_lhs rhs fv_rhs)
415   = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)     $
416
417     bindLocatedLocalsFV doc (map get_var vars)          $ \ ids ->
418     mapFvRn rn_var (vars `zip` ids)             `thenM` \ (vars', fv_vars) ->
419
420     rnLExpr lhs                                 `thenM` \ (lhs', fv_lhs') ->
421     rnLExpr rhs                                 `thenM` \ (rhs', fv_rhs') ->
422
423     checkValidRule rule_name ids lhs' fv_lhs'   `thenM_`
424
425     returnM (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
426              fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs')
427   where
428     doc = text "In the transformation rule" <+> ftext rule_name
429   
430     get_var (RuleBndr v)      = v
431     get_var (RuleBndrSig v _) = v
432
433     rn_var (RuleBndr (L loc v), id)
434         = returnM (RuleBndr (L loc id), emptyFVs)
435     rn_var (RuleBndrSig (L loc v) t, id)
436         = rnHsTypeFVs doc t     `thenM` \ (t', fvs) ->
437           returnM (RuleBndrSig (L loc id) t', fvs)
438
439 badRuleVar name var
440   = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
441          ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> 
442                 ptext SLIT("does not appear on left hand side")]
443 \end{code}
444
445 Note [Rule LHS validity checking]
446 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
447 Check the shape of a transformation rule LHS.  Currently we only allow
448 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
449 @forall@'d variables.  
450
451 We used restrict the form of the 'ei' to prevent you writing rules
452 with LHSs with a complicated desugaring (and hence unlikely to match);
453 (e.g. a case expression is not allowed: too elaborate.)
454
455 But there are legitimate non-trivial args ei, like sections and
456 lambdas.  So it seems simmpler not to check at all, and that is why
457 check_e is commented out.
458         
459 \begin{code}
460 checkValidRule rule_name ids lhs' fv_lhs'
461   = do  {       -- Check for the form of the LHS
462           case (validRuleLhs ids lhs') of
463                 Nothing  -> return ()
464                 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
465
466                 -- Check that LHS vars are all bound
467         ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
468         ; mappM (addErr . badRuleVar rule_name) bad_vars }
469
470 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
471 -- Nothing => OK
472 -- Just e  => Not ok, and e is the offending expression
473 validRuleLhs foralls lhs
474   = checkl lhs
475   where
476     checkl (L loc e) = check e
477
478     check (OpApp e1 op _ e2)              = checkl op `seqMaybe` checkl_e e1 `seqMaybe` checkl_e e2
479     check (HsApp e1 e2)                   = checkl e1 `seqMaybe` checkl_e e2
480     check (HsVar v) | v `notElem` foralls = Nothing
481     check other                           = Just other  -- Failure
482
483         -- Check an argument
484     checkl_e (L loc e) = Nothing        -- Was (check_e e); see Note [Rule LHS validity checking]
485
486 {-      Commented out; see Note [Rule LHS validity checking] above 
487     check_e (HsVar v)     = Nothing
488     check_e (HsPar e)     = checkl_e e
489     check_e (HsLit e)     = Nothing
490     check_e (HsOverLit e) = Nothing
491
492     check_e (OpApp e1 op _ e2)   = checkl_e e1 `seqMaybe` checkl_e op `seqMaybe` checkl_e e2
493     check_e (HsApp e1 e2)        = checkl_e e1 `seqMaybe` checkl_e e2
494     check_e (NegApp e _)         = checkl_e e
495     check_e (ExplicitList _ es)  = checkl_es es
496     check_e (ExplicitTuple es _) = checkl_es es
497     check_e other                = Just other   -- Fails
498
499     checkl_es es = foldr (seqMaybe . checkl_e) Nothing es
500 -}
501
502 badRuleLhsErr name lhs bad_e
503   = sep [ptext SLIT("Rule") <+> ftext name <> colon,
504          nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e, 
505                        ptext SLIT("in left-hand side:") <+> ppr lhs])]
506     $$
507     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
508 \end{code}
509
510
511 %*********************************************************
512 %*                                                      *
513 \subsection{Type, class and iface sig declarations}
514 %*                                                      *
515 %*********************************************************
516
517 @rnTyDecl@ uses the `global name function' to create a new type
518 declaration in which local names have been replaced by their original
519 names, reporting any unknown names.
520
521 Renaming type variables is a pain. Because they now contain uniques,
522 it is necessary to pass in an association list which maps a parsed
523 tyvar to its @Name@ representation.
524 In some cases (type signatures of values),
525 it is even necessary to go over the type first
526 in order to get the set of tyvars used by it, make an assoc list,
527 and then go over it again to rename the tyvars!
528 However, we can also do some scoping checks at the same time.
529
530 \begin{code}
531 rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name})
532   = lookupLocatedTopBndrRn name         `thenM` \ name' ->
533     returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
534              emptyFVs)
535
536 -- all flavours of type family declarations ("type family", "newtype fanily",
537 -- and "data family")
538 rnTyClDecl (tydecl@TyFamily {}) =
539   rnFamily tydecl bindTyVarsRn
540
541 -- "data", "newtype", "data instance, and "newtype instance" declarations
542 rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, 
543                            tcdLName = tycon, tcdTyVars = tyvars, 
544                            tcdTyPats = typatsMaybe, tcdCons = condecls, 
545                            tcdKindSig = sig, tcdDerivs = derivs})
546   | is_vanilla            -- Normal Haskell data type decl
547   = ASSERT( isNothing sig )     -- In normal H98 form, kind signature on the 
548                                 -- data type is syntactically illegal
549     bindTyVarsRn data_doc tyvars                $ \ tyvars' ->
550     do  { tycon' <- if isFamInstDecl tydecl
551                     then lookupLocatedOccRn     tycon -- may be imported family
552                     else lookupLocatedTopBndrRn tycon
553         ; context' <- rnContext data_doc context
554         ; typats' <- rnTyPats data_doc typatsMaybe
555         ; (derivs', deriv_fvs) <- rn_derivs derivs
556         ; checkDupNames data_doc con_names
557         ; condecls' <- rnConDecls (unLoc tycon') condecls
558         ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', 
559                            tcdLName = tycon', tcdTyVars = tyvars', 
560                            tcdTyPats = typats', tcdKindSig = Nothing, 
561                            tcdCons = condecls', tcdDerivs = derivs'}, 
562                    delFVs (map hsLTyVarName tyvars')    $
563                    extractHsCtxtTyNames context'        `plusFV`
564                    plusFVs (map conDeclFVs condecls')   `plusFV`
565                    deriv_fvs                            `plusFV`
566                    (if isFamInstDecl tydecl
567                    then unitFV (unLoc tycon')   -- type instance => use
568                    else emptyFVs)) 
569         }
570
571   | otherwise             -- GADT
572   = ASSERT( none typatsMaybe )    -- GADTs cannot have type patterns for now
573     do  { tycon' <- if isFamInstDecl tydecl
574                     then lookupLocatedOccRn     tycon -- may be imported family
575                     else lookupLocatedTopBndrRn tycon
576         ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
577         ; tyvars' <- bindTyVarsRn data_doc tyvars 
578                                   (\ tyvars' -> return tyvars')
579                 -- For GADTs, the type variables in the declaration 
580                 -- do not scope over the constructor signatures
581                 --      data T a where { T1 :: forall b. b-> b }
582         ; (derivs', deriv_fvs) <- rn_derivs derivs
583         ; checkDupNames data_doc con_names
584         ; condecls' <- rnConDecls (unLoc tycon') condecls
585         ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], 
586                            tcdLName = tycon', tcdTyVars = tyvars', 
587                            tcdTyPats = Nothing, tcdKindSig = sig,
588                            tcdCons = condecls', tcdDerivs = derivs'}, 
589                    plusFVs (map conDeclFVs condecls') `plusFV` 
590                    deriv_fvs                          `plusFV`
591                    (if isFamInstDecl tydecl
592                    then unitFV (unLoc tycon')   -- type instance => use
593                    else emptyFVs))
594         }
595   where
596     is_vanilla = case condecls of       -- Yuk
597                      []                    -> True
598                      L _ (ConDecl { con_res = ResTyH98 }) : _  -> True
599                      other                 -> False
600
601     none Nothing   = True
602     none (Just []) = True
603     none _         = False
604
605     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
606     con_names = map con_names_helper condecls
607
608     con_names_helper (L _ c) = con_name c
609
610     rn_derivs Nothing   = returnM (Nothing, emptyFVs)
611     rn_derivs (Just ds) = rnLHsTypes data_doc ds        `thenM` \ ds' -> 
612                           returnM (Just ds', extractHsTyNames_s ds')
613
614 -- "type" and "type instance" declarations
615 rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
616                               tcdTyPats = typatsMaybe, tcdSynRhs = ty})
617   = bindTyVarsRn syn_doc tyvars                 $ \ tyvars' ->
618     do { name' <- if isFamInstDecl tydecl
619                   then lookupLocatedOccRn     name -- may be imported family
620                   else lookupLocatedTopBndrRn name
621        ; typats' <- rnTyPats syn_doc typatsMaybe
622        ; (ty', fvs) <- rnHsTypeFVs syn_doc ty
623        ; returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars', 
624                              tcdTyPats = typats', tcdSynRhs = ty'},
625                   delFVs (map hsLTyVarName tyvars') $
626                   fvs                         `plusFV`
627                    (if isFamInstDecl tydecl
628                    then unitFV (unLoc name')    -- type instance => use
629                    else emptyFVs))
630        }
631   where
632     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
633
634 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, 
635                        tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
636                        tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
637   = do  { cname' <- lookupLocatedTopBndrRn cname
638
639         -- Tyvars scope over superclass context and method signatures
640         ; (tyvars', context', fds', ats', ats_fvs, sigs')
641             <- bindTyVarsRn cls_doc tyvars $ \ tyvars' -> do
642              { context' <- rnContext cls_doc context
643              ; fds' <- rnFds cls_doc fds
644              ; (ats', ats_fvs) <- rnATs ats
645              ; sigs' <- renameSigs okClsDclSig sigs
646              ; return   (tyvars', context', fds', ats', ats_fvs, sigs') }
647
648         -- Check for duplicates among the associated types
649         ; let at_rdr_names_w_locs = [tcdLName ty | L _ ty <- ats]
650         ; checkDupNames at_doc at_rdr_names_w_locs
651
652         -- Check the signatures
653         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
654         ; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
655         ; checkDupNames sig_doc sig_rdr_names_w_locs
656                 -- Typechecker is responsible for checking that we only
657                 -- give default-method bindings for things in this class.
658                 -- The renamer *could* check this for class decls, but can't
659                 -- for instance decls.
660
661         -- The newLocals call is tiresome: given a generic class decl
662         --      class C a where
663         --        op :: a -> a
664         --        op {| x+y |} (Inl a) = ...
665         --        op {| x+y |} (Inr b) = ...
666         --        op {| a*b |} (a*b)   = ...
667         -- we want to name both "x" tyvars with the same unique, so that they are
668         -- easy to group together in the typechecker.  
669         ; (mbinds', meth_fvs) 
670             <- extendTyVarEnvForMethodBinds tyvars' $ do
671             { name_env <- getLocalRdrEnv
672             ; let meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds
673                   gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds,
674                                                  not (unLoc tv `elemLocalRdrEnv` name_env) ]
675             ; checkDupNames meth_doc meth_rdr_names_w_locs
676             ; gen_tyvars <- newLocalsRn gen_rdr_tyvars_w_locs
677             ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
678
679   -- Haddock docs 
680         ; docs' <- mapM (wrapLocM rnDocDecl) docs
681
682         ; return (ClassDecl { tcdCtxt = context', tcdLName = cname', 
683                               tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
684                               tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
685
686                   delFVs (map hsLTyVarName tyvars')     $
687                   extractHsCtxtTyNames context'         `plusFV`
688                   plusFVs (map extractFunDepNames (map unLoc fds'))  `plusFV`
689                   hsSigsFVs sigs'                       `plusFV`
690                   meth_fvs                              `plusFV`
691                   ats_fvs) }
692   where
693     meth_doc = text "In the default-methods for class"  <+> ppr cname
694     cls_doc  = text "In the declaration for class"      <+> ppr cname
695     sig_doc  = text "In the signatures for class"       <+> ppr cname
696     at_doc   = text "In the associated types for class" <+> ppr cname
697
698 badGadtStupidTheta tycon
699   = vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"),
700           ptext SLIT("(You can put a context on each contructor, though.)")]
701 \end{code}
702
703 %*********************************************************
704 %*                                                      *
705 \subsection{Support code for type/data declarations}
706 %*                                                      *
707 %*********************************************************
708
709 \begin{code}
710 -- Although, we are processing type patterns here, all type variables will
711 -- already be in scope (they are the same as in the 'tcdTyVars' field of the
712 -- type declaration to which these patterns belong)
713 --
714 rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name])
715 rnTyPats _   Nothing       = return Nothing
716 rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats
717
718 rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
719 rnConDecls tycon condecls
720   = mappM (wrapLocM rnConDecl) condecls
721
722 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
723 rnConDecl (ConDecl name expl tvs cxt details res_ty mb_doc)
724   = do  { addLocM checkConName name
725
726         ; new_name <- lookupLocatedTopBndrRn name
727         ; name_env <- getLocalRdrEnv
728         
729         -- For H98 syntax, the tvs are the existential ones
730         -- For GADT syntax, the tvs are all the quantified tyvars
731         -- Hence the 'filter' in the ResTyH98 case only
732         ; let not_in_scope  = not . (`elemLocalRdrEnv` name_env) . unLoc
733               arg_tys       = hsConArgs details
734               implicit_tvs  = case res_ty of
735                                 ResTyH98 -> filter not_in_scope $
736                                                 get_rdr_tvs arg_tys
737                                 ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
738               tvs' = case expl of
739                         Explicit -> tvs
740                         Implicit -> userHsTyVarBndrs implicit_tvs
741
742         ; mb_doc' <- rnMbLHsDoc mb_doc 
743
744         ; bindTyVarsRn doc tvs' $ \new_tyvars -> do
745         { new_context <- rnContext doc cxt
746         ; new_details <- rnConDetails doc details
747         ; (new_details', new_res_ty)  <- rnConResult doc new_details res_ty
748         ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty mb_doc') }}
749  where
750     doc = text "In the definition of data constructor" <+> quotes (ppr name)
751     get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
752
753 rnConResult _ details ResTyH98 = return (details, ResTyH98)
754
755 rnConResult doc details (ResTyGADT ty) = do
756     ty' <- rnHsSigType doc ty
757     let (arg_tys, res_ty) = splitHsFunType ty'
758         -- We can split it up, now the renamer has dealt with fixities
759     case details of
760         PrefixCon _xs -> ASSERT( null _xs ) return (PrefixCon arg_tys, ResTyGADT res_ty)
761         RecCon fields -> return (details, ResTyGADT ty')
762         InfixCon {}   -> panic "rnConResult"
763
764 rnConDetails doc (PrefixCon tys)
765   = mappM (rnLHsType doc) tys   `thenM` \ new_tys  ->
766     returnM (PrefixCon new_tys)
767
768 rnConDetails doc (InfixCon ty1 ty2)
769   = rnLHsType doc ty1           `thenM` \ new_ty1 ->
770     rnLHsType doc ty2           `thenM` \ new_ty2 ->
771     returnM (InfixCon new_ty1 new_ty2)
772
773 rnConDetails doc (RecCon fields)
774   = checkDupNames doc field_names       `thenM_`
775     mappM (rnField doc) fields          `thenM` \ new_fields ->
776     returnM (RecCon new_fields)
777   where
778     field_names = [ name | HsRecField name _ _ <- fields ]
779
780 -- Document comments are renamed to Nothing here
781 rnField doc (HsRecField name ty haddock_doc)
782   = lookupLocatedTopBndrRn name `thenM` \ new_name ->
783     rnLHsType doc ty            `thenM` \ new_ty ->
784     rnMbLHsDoc haddock_doc      `thenM` \ new_haddock_doc ->
785     returnM (HsRecField new_name new_ty new_haddock_doc) 
786
787 -- Rename family declarations
788 --
789 -- * This function is parametrised by the routine handling the index
790 --   variables.  On the toplevel, these are defining occurences, whereas they
791 --   are usage occurences for associated types.
792 --
793 rnFamily :: TyClDecl RdrName 
794          -> (SDoc -> [LHsTyVarBndr RdrName] -> 
795              ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
796              RnM (TyClDecl Name, FreeVars))
797          -> RnM (TyClDecl Name, FreeVars)
798
799 rnFamily (tydecl@TyFamily {tcdFlavour = flavour, 
800                            tcdLName = tycon, tcdTyVars = tyvars}) 
801         bindIdxVars =
802       do { checkM (isDataFlavour flavour                      -- for synonyms,
803                    || not (null tyvars)) $ addErr needOneIdx  -- #indexes >= 1
804          ; bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do {
805          ; tycon' <- lookupLocatedTopBndrRn tycon
806          ; returnM (TyFamily {tcdFlavour = flavour, tcdLName = tycon', 
807                               tcdTyVars = tyvars', tcdKind = tcdKind tydecl}, 
808                     emptyFVs) 
809          } }
810       where
811         isDataFlavour (DataFamily _) = True
812         isDataFlavour _              = False
813
814 family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon)
815 needOneIdx = text "Type family declarations requires at least one type index"
816
817 -- Rename associated type declarations (in classes)
818 --
819 -- * This can be family declarations and (default) type instances
820 --
821 rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
822 rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
823   where
824     rn_at (tydecl@TyFamily  {}) = rnFamily tydecl lookupIdxVars
825     rn_at (tydecl@TySynonym {}) = 
826       do
827         checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
828         rnTyClDecl tydecl
829     rn_at _                      = panic "RnSource.rnATs: invalid TyClDecl"
830
831     lookupIdxVars _ tyvars cont = 
832       do { checkForDups tyvars;
833          ; tyvars' <- mappM lookupIdxVar tyvars
834          ; cont tyvars'
835          }
836     -- Type index variables must be class parameters, which are the only
837     -- type variables in scope at this point.
838     lookupIdxVar (L l tyvar) =
839       do
840         name' <- lookupOccRn (hsTyVarName tyvar)
841         return $ L l (replaceTyVarName tyvar name')
842
843     -- Type variable may only occur once.
844     --
845     checkForDups [] = return ()
846     checkForDups (L loc tv:ltvs) = 
847       do { setSrcSpan loc $
848              when (hsTyVarName tv `ltvElem` ltvs) $
849                addErr (repeatedTyVar tv)
850          ; checkForDups ltvs
851          }
852
853     rdrName `ltvElem` [] = False
854     rdrName `ltvElem` (L _ tv:ltvs)
855       | rdrName == hsTyVarName tv = True
856       | otherwise                 = rdrName `ltvElem` ltvs
857
858 noPatterns = text "Default definition for an associated synonym cannot have"
859              <+> text "type pattern"
860
861 repeatedTyVar tv = ptext SLIT("Illegal repeated type variable") <+>
862                    quotes (ppr tv)
863
864 -- This data decl will parse OK
865 --      data T = a Int
866 -- treating "a" as the constructor.
867 -- It is really hard to make the parser spot this malformation.
868 -- So the renamer has to check that the constructor is legal
869 --
870 -- We can get an operator as the constructor, even in the prefix form:
871 --      data T = :% Int Int
872 -- from interface files, which always print in prefix form
873
874 checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
875
876 badDataCon name
877    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
878 \end{code}
879
880
881 %*********************************************************
882 %*                                                      *
883 \subsection{Support code to rename types}
884 %*                                                      *
885 %*********************************************************
886
887 \begin{code}
888 rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
889
890 rnFds doc fds
891   = mappM (wrapLocM rn_fds) fds
892   where
893     rn_fds (tys1, tys2)
894       = rnHsTyVars doc tys1             `thenM` \ tys1' ->
895         rnHsTyVars doc tys2             `thenM` \ tys2' ->
896         returnM (tys1', tys2')
897
898 rnHsTyVars doc tvs  = mappM (rnHsTyvar doc) tvs
899 rnHsTyvar doc tyvar = lookupOccRn tyvar
900 \end{code}
901
902
903 %*********************************************************
904 %*                                                      *
905                 Splices
906 %*                                                      *
907 %*********************************************************
908
909 Note [Splices]
910 ~~~~~~~~~~~~~~
911 Consider
912         f = ...
913         h = ...$(thing "f")...
914
915 The splice can expand into literally anything, so when we do dependency
916 analysis we must assume that it might mention 'f'.  So we simply treat
917 all locally-defined names as mentioned by any splice.  This is terribly
918 brutal, but I don't see what else to do.  For example, it'll mean
919 that every locally-defined thing will appear to be used, so no unused-binding
920 warnings.  But if we miss the dependency, then we might typecheck 'h' before 'f',
921 and that will crash the type checker because 'f' isn't in scope.
922
923 Currently, I'm not treating a splice as also mentioning every import,
924 which is a bit inconsistent -- but there are a lot of them.  We might
925 thereby get some bogus unused-import warnings, but we won't crash the
926 type checker.  Not very satisfactory really.
927
928 \begin{code}
929 rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
930 rnSplice (HsSplice n expr)
931   = do  { checkTH expr "splice"
932         ; loc  <- getSrcSpanM
933         ; [n'] <- newLocalsRn [L loc n]
934         ; (expr', fvs) <- rnLExpr expr
935
936         -- Ugh!  See Note [Splices] above
937         ; lcl_rdr <- getLocalRdrEnv
938         ; gbl_rdr <- getGlobalRdrEnv
939         ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr, 
940                                                     isLocalGRE gre]
941               lcl_names = mkNameSet (occEnvElts lcl_rdr)
942
943         ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
944
945 #ifdef GHCI 
946 checkTH e what = returnM ()     -- OK
947 #else
948 checkTH e what  -- Raise an error in a stage-1 compiler
949   = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>  
950                   ptext SLIT("illegal in a stage-1 compiler"),
951                   nest 2 (ppr e)])
952 #endif   
953 \end{code}