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