9e1637919e0bdf83431eb296d219f4d743da3f1e
[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, rnTyClDecls, findSplice
9     ) where
10
11 #include "HsVersions.h"
12
13 import {-# SOURCE #-} RnExpr( rnLExpr )
14 #ifdef GHCI
15 import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl )
16 #endif  /* GHCI */
17
18 import HsSyn
19 import RdrName          ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc )
20 import RdrHsSyn         ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
21 import RnHsSyn
22 import RnTypes          ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext, rnConDeclFields )
23 import RnBinds          ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn,
24                                 makeMiniFixityEnv)
25 import RnEnv            ( lookupLocalDataTcNames, lookupLocatedOccRn,
26                           lookupTopBndrRn, lookupLocatedTopBndrRn,
27                           lookupOccRn, newLocalBndrsRn, bindLocalNamesFV,
28                           bindLocatedLocalsFV, bindPatSigTyVarsFV,
29                           bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn,
30                           bindLocalNames, checkDupRdrNames, mapFvRn
31                         )
32 import RnNames          ( getLocalNonValBinders, extendGlobalRdrEnvRn )
33 import HscTypes         ( GenAvailInfo(..), availsToNameSet )
34 import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
35 import TcRnMonad
36
37 import ForeignCall      ( CCallTarget(..) )
38 import Module
39 import HscTypes         ( Warnings(..), plusWarns )
40 import Class            ( FunDep )
41 import Name             ( Name, nameOccName )
42 import NameSet
43 import NameEnv
44 import Outputable
45 import Bag
46 import FastString
47 import Util             ( filterOut )
48 import SrcLoc
49 import DynFlags
50 import HscTypes         ( HscEnv, hsc_dflags )
51 import BasicTypes       ( Boxity(..) )
52 import ListSetOps       ( findDupsEq )
53
54
55 import Control.Monad
56 import Data.Maybe
57 \end{code}
58
59 \begin{code}
60 -- XXX
61 thenM :: Monad a => a b -> (b -> a c) -> a c
62 thenM = (>>=)
63
64 thenM_ :: Monad a => a b -> a c -> a c
65 thenM_ = (>>)
66 \end{code}
67
68 @rnSourceDecl@ `renames' declarations.
69 It simultaneously performs dependency analysis and precedence parsing.
70 It also does the following error checks:
71 \begin{enumerate}
72 \item
73 Checks that tyvars are used properly. This includes checking
74 for undefined tyvars, and tyvars in contexts that are ambiguous.
75 (Some of this checking has now been moved to module @TcMonoType@,
76 since we don't have functional dependency information at this point.)
77 \item
78 Checks that all variable occurences are defined.
79 \item 
80 Checks the @(..)@ etc constraints in the export list.
81 \end{enumerate}
82
83
84 \begin{code}
85 -- Brings the binders of the group into scope in the appropriate places;
86 -- does NOT assume that anything is in scope already
87 rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
88 -- Rename a HsGroup; used for normal source files *and* hs-boot files
89 rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
90                             hs_tyclds  = tycl_decls,
91                             hs_instds  = inst_decls,
92                             hs_derivds = deriv_decls,
93                             hs_fixds   = fix_decls,
94                             hs_warnds  = warn_decls,
95                             hs_annds   = ann_decls,
96                             hs_fords   = foreign_decls,
97                             hs_defds   = default_decls,
98                             hs_ruleds  = rule_decls,
99                             hs_docs    = docs })
100  = do {
101    -- (A) Process the fixity declarations, creating a mapping from
102    --     FastStrings to FixItems.
103    --     Also checks for duplcates.
104    local_fix_env <- makeMiniFixityEnv fix_decls;
105
106    -- (B) Bring top level binders (and their fixities) into scope,
107    --     *except* for the value bindings, which get brought in below.
108    --     However *do* include class ops, data constructors
109    --     And for hs-boot files *do* include the value signatures
110    tc_avails <- getLocalNonValBinders group ;
111    tc_envs <- extendGlobalRdrEnvRn tc_avails local_fix_env ;
112    setEnvs tc_envs $ do {
113
114    failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
115
116    -- (C) Extract the mapping from data constructors to field names and
117    --     extend the record field env.
118    --     This depends on the data constructors and field names being in
119    --     scope from (B) above
120    inNewEnv (extendRecordFieldEnv tycl_decls inst_decls) $ \ _ -> do {
121
122    -- (D) Rename the left-hand sides of the value bindings.
123    --     This depends on everything from (B) being in scope,
124    --     and on (C) for resolving record wild cards.
125    --     It uses the fixity env from (A) to bind fixities for view patterns.
126    new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
127    -- bind the LHSes (and their fixities) in the global rdr environment
128    let { val_binders = collectHsValBinders new_lhs ;
129          val_bndr_set = mkNameSet val_binders ;
130          all_bndr_set = val_bndr_set `unionNameSets` availsToNameSet tc_avails ;
131          val_avails = map Avail val_binders 
132        } ;
133    (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ;
134    setEnvs (tcg_env, tcl_env) $ do {
135
136    --  Now everything is in scope, as the remaining renaming assumes.
137
138    -- (E) Rename type and class decls
139    --     (note that value LHSes need to be in scope for default methods)
140    --
141    -- You might think that we could build proper def/use information
142    -- for type and class declarations, but they can be involved
143    -- in mutual recursion across modules, and we only do the SCC
144    -- analysis for them in the type checker.
145    -- So we content ourselves with gathering uses only; that
146    -- means we'll only report a declaration as unused if it isn't
147    -- mentioned at all.  Ah well.
148    traceRn (text "Start rnTyClDecls") ;
149    (rn_tycl_decls, src_fvs1) <- rnList rnTyClDecl tycl_decls ;
150
151    -- (F) Rename Value declarations right-hand sides
152    traceRn (text "Start rnmono") ;
153    (rn_val_decls, bind_dus) <- rnTopBindsRHS val_bndr_set new_lhs ;
154    traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
155
156    -- (G) Rename Fixity and deprecations
157    
158    -- Rename fixity declarations and error if we try to
159    -- fix something from another module (duplicates were checked in (A))
160    rn_fix_decls <- rnSrcFixityDecls all_bndr_set fix_decls ;
161
162    -- Rename deprec decls;
163    -- check for duplicates and ensure that deprecated things are defined locally
164    -- at the moment, we don't keep these around past renaming
165    rn_warns <- rnSrcWarnDecls all_bndr_set warn_decls ;
166
167    -- (H) Rename Everything else
168
169    (rn_inst_decls,    src_fvs2) <- rnList rnSrcInstDecl   inst_decls ;
170    (rn_rule_decls,    src_fvs3) <- setOptM Opt_ScopedTypeVariables $
171                                    rnList rnHsRuleDecl    rule_decls ;
172                            -- Inside RULES, scoped type variables are on
173    (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
174    (rn_ann_decls,     src_fvs5) <- rnList rnAnnDecl       ann_decls ;
175    (rn_default_decls, src_fvs6) <- rnList rnDefaultDecl   default_decls ;
176    (rn_deriv_decls,   src_fvs7) <- rnList rnSrcDerivDecl  deriv_decls ;
177       -- Haddock docs; no free vars
178    rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
179
180    -- (I) Compute the results and return
181    let {rn_group = HsGroup { hs_valds   = rn_val_decls,
182                              hs_tyclds  = rn_tycl_decls,
183                              hs_instds  = rn_inst_decls,
184                              hs_derivds = rn_deriv_decls,
185                              hs_fixds   = rn_fix_decls,
186                              hs_warnds  = [], -- warns are returned in the tcg_env
187                                              -- (see below) not in the HsGroup
188                              hs_fords  = rn_foreign_decls,
189                              hs_annds  = rn_ann_decls,
190                              hs_defds  = rn_default_decls,
191                              hs_ruleds = rn_rule_decls,
192                              hs_docs   = rn_docs } ;
193
194         tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ;
195         ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ;
196         other_def  = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ;
197         other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, 
198                               src_fvs5, src_fvs6, src_fvs7] ;
199                 -- It is tiresome to gather the binders from type and class decls
200
201         src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
202                 -- Instance decls may have occurrences of things bound in bind_dus
203                 -- so we must put other_fvs last
204
205         final_tcg_env = let tcg_env' = (tcg_env `addTcgDUs` src_dus)
206                         in -- we return the deprecs in the env, not in the HsGroup above
207                         tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
208        } ;
209
210    traceRn (text "finish rnSrc" <+> ppr rn_group) ;
211    traceRn (text "finish Dus" <+> ppr src_dus ) ;
212    return (final_tcg_env, rn_group)
213                     }}}}
214
215 -- some utils because we do this a bunch above
216 -- compute and install the new env
217 inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a
218 inNewEnv env cont = do e <- env
219                        setGblEnv e $ cont e
220
221 rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
222 -- Used for external core
223 rnTyClDecls tycl_decls = do  (decls', _fvs) <- rnList rnTyClDecl tycl_decls
224                              return decls'
225
226 addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv 
227 -- This function could be defined lower down in the module hierarchy, 
228 -- but there doesn't seem anywhere very logical to put it.
229 addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
230
231 rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
232 rnList f xs = mapFvRn (wrapLocFstM f) xs
233 \end{code}
234
235
236 %*********************************************************
237 %*                                                       *
238         HsDoc stuff
239 %*                                                       *
240 %*********************************************************
241
242 \begin{code}
243 rnDocDecl :: DocDecl -> RnM DocDecl
244 rnDocDecl (DocCommentNext doc) = do 
245   rn_doc <- rnHsDoc doc
246   return (DocCommentNext rn_doc)
247 rnDocDecl (DocCommentPrev doc) = do 
248   rn_doc <- rnHsDoc doc
249   return (DocCommentPrev rn_doc)
250 rnDocDecl (DocCommentNamed str doc) = do
251   rn_doc <- rnHsDoc doc
252   return (DocCommentNamed str rn_doc)
253 rnDocDecl (DocGroup lev doc) = do
254   rn_doc <- rnHsDoc doc
255   return (DocGroup lev rn_doc)
256 \end{code}
257
258
259 %*********************************************************
260 %*                                                       *
261         Source-code fixity declarations
262 %*                                                       *
263 %*********************************************************
264
265 \begin{code}
266 rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name]
267 -- Rename the fixity decls, so we can put
268 -- the renamed decls in the renamed syntax tree
269 -- Errors if the thing being fixed is not defined locally.
270 --
271 -- The returned FixitySigs are not actually used for anything,
272 -- except perhaps the GHCi API
273 rnSrcFixityDecls bound_names fix_decls
274   = do fix_decls <- mapM rn_decl fix_decls
275        return (concat fix_decls)
276   where
277     rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]
278         -- GHC extension: look up both the tycon and data con 
279         -- for con-like things; hence returning a list
280         -- If neither are in scope, report an error; otherwise
281         -- return a fixity sig for each (slightly odd)
282     rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity))
283       = setSrcSpan name_loc $
284                     -- this lookup will fail if the definition isn't local
285         do names <- lookupLocalDataTcNames bound_names what rdr_name
286            return [ L loc (FixitySig (L name_loc name) fixity)
287                   | name <- names ]
288     what = ptext (sLit "fixity signature")
289 \end{code}
290
291
292 %*********************************************************
293 %*                                                       *
294         Source-code deprecations declarations
295 %*                                                       *
296 %*********************************************************
297
298 Check that the deprecated names are defined, are defined locally, and
299 that there are no duplicate deprecations.
300
301 It's only imported deprecations, dealt with in RnIfaces, that we
302 gather them together.
303
304 \begin{code}
305 -- checks that the deprecations are defined locally, and that there are no duplicates
306 rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings
307 rnSrcWarnDecls _bound_names [] 
308   = return NoWarnings
309
310 rnSrcWarnDecls bound_names decls 
311   = do { -- check for duplicates
312        ; mapM_ (\ (L loc rdr:lrdr':_) -> addErrAt loc (dupWarnDecl lrdr' rdr)) 
313                warn_rdr_dups
314        ; pairs_s <- mapM (addLocM rn_deprec) decls
315        ; return (WarnSome ((concat pairs_s))) }
316  where
317    rn_deprec (Warning rdr_name txt)
318        -- ensures that the names are defined locally
319      = lookupLocalDataTcNames bound_names what rdr_name `thenM` \ names ->
320        return [(nameOccName name, txt) | name <- names]
321    
322    what = ptext (sLit "deprecation")
323
324    -- look for duplicates among the OccNames;
325    -- we check that the names are defined above
326    -- invt: the lists returned by findDupsEq always have at least two elements
327    warn_rdr_dups = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
328                      (map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls)
329                
330 dupWarnDecl :: Located RdrName -> RdrName -> SDoc
331 -- Located RdrName -> DeprecDecl RdrName -> SDoc
332 dupWarnDecl (L loc _) rdr_name
333   = vcat [ptext (sLit "Multiple warning declarations for") <+> quotes (ppr rdr_name),
334           ptext (sLit "also at ") <+> ppr loc]
335
336 \end{code}
337
338 %*********************************************************
339 %*                                                      *
340 \subsection{Annotation declarations}
341 %*                                                      *
342 %*********************************************************
343
344 \begin{code}
345 rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars)
346 rnAnnDecl (HsAnnotation provenance expr) = do
347     (provenance', provenance_fvs) <- rnAnnProvenance provenance
348     (expr', expr_fvs) <- rnLExpr expr
349     return (HsAnnotation provenance' expr', provenance_fvs `plusFV` expr_fvs)
350
351 rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars)
352 rnAnnProvenance provenance = do
353     provenance' <- modifyAnnProvenanceNameM lookupTopBndrRn provenance
354     return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))
355 \end{code}
356
357 %*********************************************************
358 %*                                                      *
359 \subsection{Default declarations}
360 %*                                                      *
361 %*********************************************************
362
363 \begin{code}
364 rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars)
365 rnDefaultDecl (DefaultDecl tys)
366   = mapFvRn (rnHsTypeFVs doc_str) tys   `thenM` \ (tys', fvs) ->
367     return (DefaultDecl tys', fvs)
368   where
369     doc_str = text "In a `default' declaration"
370 \end{code}
371
372 %*********************************************************
373 %*                                                      *
374 \subsection{Foreign declarations}
375 %*                                                      *
376 %*********************************************************
377
378 \begin{code}
379 rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
380 rnHsForeignDecl (ForeignImport name ty spec)
381   = getTopEnv                           `thenM` \ (topEnv :: HscEnv) ->
382     lookupLocatedTopBndrRn name         `thenM` \ name' ->
383     rnHsTypeFVs (fo_decl_msg name) ty   `thenM` \ (ty', fvs) ->
384
385     -- Mark any PackageTarget style imports as coming from the current package
386     let packageId       = thisPackage $ hsc_dflags topEnv
387         spec'           = patchForeignImport packageId spec
388
389     in  return (ForeignImport name' ty' spec', fvs)
390
391 rnHsForeignDecl (ForeignExport name ty spec)
392   = lookupLocatedOccRn name             `thenM` \ name' ->
393     rnHsTypeFVs (fo_decl_msg name) ty   `thenM` \ (ty', fvs) ->
394     return (ForeignExport name' ty' spec, fvs `addOneFV` unLoc name')
395         -- NB: a foreign export is an *occurrence site* for name, so 
396         --     we add it to the free-variable list.  It might, for example,
397         --     be imported from another module
398
399 fo_decl_msg :: Located RdrName -> SDoc
400 fo_decl_msg name = ptext (sLit "In the foreign declaration for") <+> ppr name
401
402
403 -- | For Windows DLLs we need to know what packages imported symbols are from
404 --      to generate correct calls. Imported symbols are tagged with the current
405 --      package, so if they get inlined across a package boundry we'll still
406 --      know where they're from.
407 --
408 patchForeignImport :: PackageId -> ForeignImport -> ForeignImport
409 patchForeignImport packageId (CImport cconv safety fs spec)
410         = CImport cconv safety fs (patchCImportSpec packageId spec) 
411
412 patchCImportSpec :: PackageId -> CImportSpec -> CImportSpec
413 patchCImportSpec packageId spec
414  = case spec of
415         CFunction callTarget    -> CFunction $ patchCCallTarget packageId callTarget
416         _                       -> spec
417
418 patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget
419 patchCCallTarget packageId callTarget
420  = case callTarget of
421         StaticTarget label Nothing
422          -> StaticTarget label (Just packageId)
423
424         _                       -> callTarget   
425
426
427 \end{code}
428
429
430 %*********************************************************
431 %*                                                      *
432 \subsection{Instance declarations}
433 %*                                                      *
434 %*********************************************************
435
436 \begin{code}
437 rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
438 rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
439         -- Used for both source and interface file decls
440   = rnHsSigType (text "an instance decl") inst_ty       `thenM` \ inst_ty' ->
441
442         -- Rename the bindings
443         -- The typechecker (not the renamer) checks that all 
444         -- the bindings are for the right class
445     let
446         meth_names  = collectMethodBinders mbinds
447         (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
448     in
449     checkDupRdrNames meth_names         `thenM_`
450         -- Check that the same method is not given twice in the
451         -- same instance decl   instance C T where
452         --                            f x = ...
453         --                            g y = ...
454         --                            f x = ...
455         -- We must use checkDupRdrNames because the Name of the
456         -- method is the Name of the class selector, whose SrcSpan
457         -- points to the class declaration
458
459     extendTyVarEnvForMethodBinds inst_tyvars (          
460         -- (Slightly strangely) the forall-d tyvars scope over
461         -- the method bindings too
462         rnMethodBinds cls (\_ -> [])    -- No scoped tyvars
463                       [] mbinds
464     )                                           `thenM` \ (mbinds', meth_fvs) ->
465         -- Rename the associated types
466         -- The typechecker (not the renamer) checks that all 
467         -- the declarations are for the right class
468     let
469         at_names = map (head . hsTyClDeclBinders) ats
470     in
471     checkDupRdrNames at_names           `thenM_`
472         -- See notes with checkDupRdrNames for methods, above
473
474     rnATInsts ats                               `thenM` \ (ats', at_fvs) ->
475
476         -- Rename the prags and signatures.
477         -- Note that the type variables are not in scope here,
478         -- so that      instance Eq a => Eq (T a) where
479         --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
480         -- works OK. 
481         --
482         -- But the (unqualified) method names are in scope
483     let 
484         binders = collectHsBindsBinders mbinds'
485         bndr_set = mkNameSet binders
486     in
487     bindLocalNames binders 
488         (renameSigs (Just bndr_set) okInstDclSig uprags)        `thenM` \ uprags' ->
489
490     return (InstDecl inst_ty' mbinds' uprags' ats',
491              meth_fvs `plusFV` at_fvs
492                       `plusFV` hsSigsFVs uprags'
493                       `plusFV` extractHsTyNames inst_ty')
494              -- We return the renamed associated data type declarations so
495              -- that they can be entered into the list of type declarations
496              -- for the binding group, but we also keep a copy in the instance.
497              -- The latter is needed for well-formedness checks in the type
498              -- checker (eg, to ensure that all ATs of the instance actually
499              -- receive a declaration). 
500              -- NB: Even the copies in the instance declaration carry copies of
501              --     the instance context after renaming.  This is a bit
502              --     strange, but should not matter (and it would be more work
503              --     to remove the context).
504 \end{code}
505
506 Renaming of the associated types in instances.  
507
508 \begin{code}
509 rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
510 rnATInsts atDecls = rnList rnATInst atDecls
511   where
512     rnATInst tydecl@TyData     {} = rnTyClDecl tydecl
513     rnATInst tydecl@TySynonym  {} = rnTyClDecl tydecl
514     rnATInst tydecl               =
515       pprPanic "RnSource.rnATInsts: invalid AT instance" 
516                (ppr (tcdName tydecl))
517 \end{code}
518
519 For the method bindings in class and instance decls, we extend the 
520 type variable environment iff -fglasgow-exts
521
522 \begin{code}
523 extendTyVarEnvForMethodBinds :: [LHsTyVarBndr Name]
524                              -> RnM (Bag (LHsBind Name), FreeVars)
525                              -> RnM (Bag (LHsBind Name), FreeVars)
526 extendTyVarEnvForMethodBinds tyvars thing_inside
527   = do  { scoped_tvs <- doptM Opt_ScopedTypeVariables
528         ; if scoped_tvs then
529                 extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
530           else
531                 thing_inside }
532 \end{code}
533
534 %*********************************************************
535 %*                                                      *
536 \subsection{Stand-alone deriving declarations}
537 %*                                                      *
538 %*********************************************************
539
540 \begin{code}
541 rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
542 rnSrcDerivDecl (DerivDecl ty)
543   = do { standalone_deriv_ok <- doptM Opt_StandaloneDeriving
544        ; unless standalone_deriv_ok (addErr standaloneDerivErr)
545        ; ty' <- rnLHsType (text "a deriving decl") ty
546        ; let fvs = extractHsTyNames ty'
547        ; return (DerivDecl ty', fvs) }
548
549 standaloneDerivErr :: SDoc
550 standaloneDerivErr 
551   = hang (ptext (sLit "Illegal standalone deriving declaration"))
552        2 (ptext (sLit "Use -XStandaloneDeriving to enable this extension"))
553 \end{code}
554
555 %*********************************************************
556 %*                                                      *
557 \subsection{Rules}
558 %*                                                      *
559 %*********************************************************
560
561 \begin{code}
562 rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
563 rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
564   = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)     $
565     bindLocatedLocalsFV (map get_var vars)              $ \ ids ->
566     do  { (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids)
567                 -- NB: The binders in a rule are always Ids
568                 --     We don't (yet) support type variables
569
570         ; (lhs', fv_lhs') <- rnLExpr lhs
571         ; (rhs', fv_rhs') <- rnLExpr rhs
572
573         ; checkValidRule rule_name ids lhs' fv_lhs'
574
575         ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
576                   fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') }
577   where
578     doc = text "In the transformation rule" <+> ftext rule_name
579   
580     get_var (RuleBndr v)      = v
581     get_var (RuleBndrSig v _) = v
582
583     rn_var (RuleBndr (L loc _), id)
584         = return (RuleBndr (L loc id), emptyFVs)
585     rn_var (RuleBndrSig (L loc _) t, id)
586         = rnHsTypeFVs doc t     `thenM` \ (t', fvs) ->
587           return (RuleBndrSig (L loc id) t', fvs)
588
589 badRuleVar :: FastString -> Name -> SDoc
590 badRuleVar name var
591   = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon,
592          ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+> 
593                 ptext (sLit "does not appear on left hand side")]
594 \end{code}
595
596 Note [Rule LHS validity checking]
597 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
598 Check the shape of a transformation rule LHS.  Currently we only allow
599 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
600 @forall@'d variables.  
601
602 We used restrict the form of the 'ei' to prevent you writing rules
603 with LHSs with a complicated desugaring (and hence unlikely to match);
604 (e.g. a case expression is not allowed: too elaborate.)
605
606 But there are legitimate non-trivial args ei, like sections and
607 lambdas.  So it seems simmpler not to check at all, and that is why
608 check_e is commented out.
609         
610 \begin{code}
611 checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM ()
612 checkValidRule rule_name ids lhs' fv_lhs'
613   = do  {       -- Check for the form of the LHS
614           case (validRuleLhs ids lhs') of
615                 Nothing  -> return ()
616                 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
617
618                 -- Check that LHS vars are all bound
619         ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
620         ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
621
622 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
623 -- Nothing => OK
624 -- Just e  => Not ok, and e is the offending expression
625 validRuleLhs foralls lhs
626   = checkl lhs
627   where
628     checkl (L _ e) = check e
629
630     check (OpApp e1 op _ e2)              = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
631     check (HsApp e1 e2)                   = checkl e1 `mplus` checkl_e e2
632     check (HsVar v) | v `notElem` foralls = Nothing
633     check other                           = Just other  -- Failure
634
635         -- Check an argument
636     checkl_e (L _ _e) = Nothing         -- Was (check_e e); see Note [Rule LHS validity checking]
637
638 {-      Commented out; see Note [Rule LHS validity checking] above 
639     check_e (HsVar v)     = Nothing
640     check_e (HsPar e)     = checkl_e e
641     check_e (HsLit e)     = Nothing
642     check_e (HsOverLit e) = Nothing
643
644     check_e (OpApp e1 op _ e2)   = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
645     check_e (HsApp e1 e2)        = checkl_e e1 `mplus` checkl_e e2
646     check_e (NegApp e _)         = checkl_e e
647     check_e (ExplicitList _ es)  = checkl_es es
648     check_e other                = Just other   -- Fails
649
650     checkl_es es = foldr (mplus . checkl_e) Nothing es
651 -}
652
653 badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
654 badRuleLhsErr name lhs bad_e
655   = sep [ptext (sLit "Rule") <+> ftext name <> colon,
656          nest 4 (vcat [ptext (sLit "Illegal expression:") <+> ppr bad_e, 
657                        ptext (sLit "in left-hand side:") <+> ppr lhs])]
658     $$
659     ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd")
660 \end{code}
661
662
663 %*********************************************************
664 %*                                                      *
665 \subsection{Type, class and iface sig declarations}
666 %*                                                      *
667 %*********************************************************
668
669 @rnTyDecl@ uses the `global name function' to create a new type
670 declaration in which local names have been replaced by their original
671 names, reporting any unknown names.
672
673 Renaming type variables is a pain. Because they now contain uniques,
674 it is necessary to pass in an association list which maps a parsed
675 tyvar to its @Name@ representation.
676 In some cases (type signatures of values),
677 it is even necessary to go over the type first
678 in order to get the set of tyvars used by it, make an assoc list,
679 and then go over it again to rename the tyvars!
680 However, we can also do some scoping checks at the same time.
681
682 \begin{code}
683 rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars)
684 rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name})
685   = lookupLocatedTopBndrRn name         `thenM` \ name' ->
686     return (ForeignType {tcdLName = name', tcdExtName = ext_name},
687              emptyFVs)
688
689 -- all flavours of type family declarations ("type family", "newtype fanily",
690 -- and "data family")
691 rnTyClDecl tydecl@TyFamily {} = rnFamily tydecl bindTyVarsFV
692
693 -- "data", "newtype", "data instance, and "newtype instance" declarations
694 rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, 
695                            tcdLName = tycon, tcdTyVars = tyvars, 
696                            tcdTyPats = typats, tcdCons = condecls, 
697                            tcdKindSig = sig, tcdDerivs = derivs}
698   = do  { tycon' <- if isFamInstDecl tydecl
699                     then lookupLocatedOccRn     tycon -- may be imported family
700                     else lookupLocatedTopBndrRn tycon
701         ; checkTc (h98_style || null (unLoc context)) 
702                   (badGadtStupidTheta tycon)
703         ; ((tyvars', context', typats', derivs'), stuff_fvs)
704                 <- bindTyVarsFV tyvars $ \ tyvars' -> do
705                                  -- Checks for distinct tyvars
706                    { context' <- rnContext data_doc context
707                    ; (typats', fvs1) <- rnTyPats data_doc tycon' typats
708                    ; (derivs', fvs2) <- rn_derivs derivs
709                    ; let fvs = fvs1 `plusFV` fvs2 `plusFV` 
710                                extractHsCtxtTyNames context'
711                    ; return ((tyvars', context', typats', derivs'), fvs) }
712
713         -- For the constructor declarations, bring into scope the tyvars 
714         -- bound by the header, but *only* in the H98 case
715         -- Reason: for GADTs, the type variables in the declaration 
716         --   do not scope over the constructor signatures
717         --   data T a where { T1 :: forall b. b-> b }
718         ; let tc_tvs_in_scope | h98_style = hsLTyVarNames tyvars'
719                               | otherwise = []
720         ; (condecls', con_fvs) <- bindLocalNamesFV tc_tvs_in_scope $
721                                   rnConDecls condecls
722                 -- No need to check for duplicate constructor decls
723                 -- since that is done by RnNames.extendGlobalRdrEnvRn
724
725         ; return (TyData {tcdND = new_or_data, tcdCtxt = context', 
726                            tcdLName = tycon', tcdTyVars = tyvars', 
727                            tcdTyPats = typats', tcdKindSig = sig,
728                            tcdCons = condecls', tcdDerivs = derivs'}, 
729                    con_fvs `plusFV` stuff_fvs)
730         }
731   where
732     h98_style = case condecls of         -- Note [Stupid theta]
733                      L _ (ConDecl { con_res = ResTyGADT {} }) : _  -> False
734                      _                                             -> True
735                                                                           
736     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
737
738     rn_derivs Nothing   = return (Nothing, emptyFVs)
739     rn_derivs (Just ds) = rnLHsTypes data_doc ds        `thenM` \ ds' -> 
740                           return (Just ds', extractHsTyNames_s ds')
741
742 -- "type" and "type instance" declarations
743 rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
744                               tcdTyPats = typats, tcdSynRhs = ty})
745   = bindTyVarsFV tyvars $ \ tyvars' -> do
746     {            -- Checks for distinct tyvars
747       name' <- if isFamInstDecl tydecl
748                   then lookupLocatedOccRn     name -- may be imported family
749                   else lookupLocatedTopBndrRn name
750     ; (typats',fvs1) <- rnTyPats syn_doc name' typats
751     ; (ty', fvs2)    <- rnHsTypeFVs syn_doc ty
752     ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars' 
753                         , tcdTyPats = typats', tcdSynRhs = ty'},
754               fvs1 `plusFV` fvs2) }
755   where
756     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
757
758 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, 
759                        tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
760                        tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
761   = do  { cname' <- lookupLocatedTopBndrRn cname
762
763         -- Tyvars scope over superclass context and method signatures
764         ; ((tyvars', context', fds', ats', sigs'), stuff_fvs)
765             <- bindTyVarsFV tyvars $ \ tyvars' -> do
766                  -- Checks for distinct tyvars
767              { context' <- rnContext cls_doc context
768              ; fds' <- rnFds cls_doc fds
769              ; (ats', at_fvs) <- rnATs ats
770              ; sigs' <- renameSigs Nothing okClsDclSig sigs
771              ; let fvs = at_fvs `plusFV` 
772                          extractHsCtxtTyNames context'  `plusFV`
773                          hsSigsFVs sigs'
774                          -- The fundeps have no free variables
775              ; return ((tyvars', context', fds', ats', sigs'), fvs) }
776
777         -- No need to check for duplicate associated type decls
778         -- since that is done by RnNames.extendGlobalRdrEnvRn
779
780         -- Check the signatures
781         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
782         ; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
783         ; checkDupRdrNames sig_rdr_names_w_locs
784                 -- Typechecker is responsible for checking that we only
785                 -- give default-method bindings for things in this class.
786                 -- The renamer *could* check this for class decls, but can't
787                 -- for instance decls.
788
789         -- The newLocals call is tiresome: given a generic class decl
790         --      class C a where
791         --        op :: a -> a
792         --        op {| x+y |} (Inl a) = ...
793         --        op {| x+y |} (Inr b) = ...
794         --        op {| a*b |} (a*b)   = ...
795         -- we want to name both "x" tyvars with the same unique, so that they are
796         -- easy to group together in the typechecker.  
797         ; (mbinds', meth_fvs) 
798             <- extendTyVarEnvForMethodBinds tyvars' $ do
799             { name_env <- getLocalRdrEnv
800             ; let gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds,
801                                                  not (unLoc tv `elemLocalRdrEnv` name_env) ]
802                 -- No need to check for duplicate method signatures
803                 -- since that is done by RnNames.extendGlobalRdrEnvRn
804                 -- and the methods are already in scope
805             ; gen_tyvars <- newLocalBndrsRn gen_rdr_tyvars_w_locs
806             ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
807
808   -- Haddock docs 
809         ; docs' <- mapM (wrapLocM rnDocDecl) docs
810
811         ; return (ClassDecl { tcdCtxt = context', tcdLName = cname', 
812                               tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
813                               tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
814                   meth_fvs `plusFV` stuff_fvs) }
815   where
816     cls_doc  = text "In the declaration for class"      <+> ppr cname
817
818 badGadtStupidTheta :: Located RdrName -> SDoc
819 badGadtStupidTheta _
820   = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
821           ptext (sLit "(You can put a context on each contructor, though.)")]
822 \end{code}
823
824 Note [Stupid theta]
825 ~~~~~~~~~~~~~~~~~~~
826 Trac #3850 complains about a regression wrt 6.10 for 
827      data Show a => T a
828 There is no reason not to allow the stupid theta if there are no data
829 constructors.  It's still stupid, but does no harm, and I don't want
830 to cause programs to break unnecessarily (notably HList).  So if there
831 are no data constructors we allow h98_style = True
832
833
834 %*********************************************************
835 %*                                                      *
836 \subsection{Support code for type/data declarations}
837 %*                                                      *
838 %*********************************************************
839
840 \begin{code}
841 rnTyPats :: SDoc -> Located Name -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name], FreeVars)
842 -- Although, we are processing type patterns here, all type variables will
843 -- already be in scope (they are the same as in the 'tcdTyVars' field of the
844 -- type declaration to which these patterns belong)
845 rnTyPats _   _  Nothing
846   = return (Nothing, emptyFVs)
847 rnTyPats doc tc (Just typats) 
848   = do { typats' <- rnLHsTypes doc typats
849        ; let fvs = addOneFV (extractHsTyNames_s typats') (unLoc tc)
850              -- type instance => use, hence addOneFV
851        ; return (Just typats', fvs) }
852
853 rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
854 rnConDecls condecls
855   = do { condecls' <- mapM (wrapLocM rnConDecl) condecls
856        ; return (condecls', plusFVs (map conDeclFVs condecls')) }
857
858 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
859 rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
860                                , con_cxt = cxt, con_details = details
861                                , con_res = res_ty, con_doc = mb_doc
862                                , con_old_rec = old_rec, con_explicit = expl })
863   = do  { addLocM checkConName name
864         ; when old_rec (addWarn (deprecRecSyntax decl))
865         ; new_name <- lookupLocatedTopBndrRn name
866
867            -- For H98 syntax, the tvs are the existential ones
868            -- For GADT syntax, the tvs are all the quantified tyvars
869            -- Hence the 'filter' in the ResTyH98 case only
870         ; rdr_env <- getLocalRdrEnv
871         ; let in_scope     = (`elemLocalRdrEnv` rdr_env) . unLoc
872               arg_tys      = hsConDeclArgTys details
873               implicit_tvs = case res_ty of
874                                ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys)
875                                ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
876               new_tvs = case expl of
877                           Explicit -> tvs
878                           Implicit -> userHsTyVarBndrs implicit_tvs
879
880         ; mb_doc' <- rnMbLHsDoc mb_doc 
881
882         ; bindTyVarsRn new_tvs $ \new_tyvars -> do
883         { new_context <- rnContext doc cxt
884         ; new_details <- rnConDeclDetails doc details
885         ; (new_details', new_res_ty)  <- rnConResult doc new_details res_ty
886         ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context 
887                        , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }}
888  where
889     doc = text "In the definition of data constructor" <+> quotes (ppr name)
890     get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
891
892 rnConResult :: SDoc
893             -> HsConDetails (LHsType Name) [ConDeclField Name]
894             -> ResType RdrName
895             -> RnM (HsConDetails (LHsType Name) [ConDeclField Name],
896                     ResType Name)
897 rnConResult _ details ResTyH98 = return (details, ResTyH98)
898 rnConResult doc details (ResTyGADT ty)
899   = do { ty' <- rnLHsType doc ty
900        ; let (arg_tys, res_ty) = splitHsFunType ty'
901                 -- We can finally split it up, 
902                 -- now the renamer has dealt with fixities
903                 -- See Note [Sorting out the result type] in RdrHsSyn
904
905              details' = case details of
906                            RecCon {}    -> details
907                            PrefixCon {} -> PrefixCon arg_tys
908                            InfixCon {}  -> pprPanic "rnConResult" (ppr ty)
909                           -- See Note [Sorting out the result type] in RdrHsSyn
910                 
911        ; when (not (null arg_tys) && case details of { RecCon {} -> True; _ -> False })
912               (addErr (badRecResTy doc))
913        ; return (details', ResTyGADT res_ty) }
914
915 rnConDeclDetails :: SDoc
916                  -> HsConDetails (LHsType RdrName) [ConDeclField RdrName]
917                  -> RnM (HsConDetails (LHsType Name) [ConDeclField Name])
918 rnConDeclDetails doc (PrefixCon tys)
919   = mapM (rnLHsType doc) tys    `thenM` \ new_tys  ->
920     return (PrefixCon new_tys)
921
922 rnConDeclDetails doc (InfixCon ty1 ty2)
923   = rnLHsType doc ty1           `thenM` \ new_ty1 ->
924     rnLHsType doc ty2           `thenM` \ new_ty2 ->
925     return (InfixCon new_ty1 new_ty2)
926
927 rnConDeclDetails doc (RecCon fields)
928   = do  { new_fields <- rnConDeclFields doc fields
929                 -- No need to check for duplicate fields
930                 -- since that is done by RnNames.extendGlobalRdrEnvRn
931         ; return (RecCon new_fields) }
932
933 -- Rename family declarations
934 --
935 -- * This function is parametrised by the routine handling the index
936 --   variables.  On the toplevel, these are defining occurences, whereas they
937 --   are usage occurences for associated types.
938 --
939 rnFamily :: TyClDecl RdrName 
940          -> ([LHsTyVarBndr RdrName] -> 
941              ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
942              RnM (TyClDecl Name, FreeVars))
943          -> RnM (TyClDecl Name, FreeVars)
944
945 rnFamily (tydecl@TyFamily {tcdFlavour = flavour, 
946                            tcdLName = tycon, tcdTyVars = tyvars}) 
947         bindIdxVars =
948       do { bindIdxVars tyvars $ \tyvars' -> do {
949          ; tycon' <- lookupLocatedTopBndrRn tycon
950          ; return (TyFamily {tcdFlavour = flavour, tcdLName = tycon', 
951                               tcdTyVars = tyvars', tcdKind = tcdKind tydecl}, 
952                     emptyFVs) 
953          } }
954 rnFamily d _ = pprPanic "rnFamily" (ppr d)
955
956 -- Rename associated type declarations (in classes)
957 --
958 -- * This can be family declarations and (default) type instances
959 --
960 rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
961 rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
962   where
963     rn_at (tydecl@TyFamily  {}) = rnFamily tydecl lookupIdxVars
964     rn_at (tydecl@TySynonym {}) = 
965       do
966         unless (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
967         rnTyClDecl tydecl
968     rn_at _                      = panic "RnSource.rnATs: invalid TyClDecl"
969
970     lookupIdxVars tyvars cont = 
971       do { checkForDups tyvars
972          ; tyvars' <- mapM lookupIdxVar tyvars
973          ; cont tyvars'
974          }
975     -- Type index variables must be class parameters, which are the only
976     -- type variables in scope at this point.
977     lookupIdxVar (L l tyvar) =
978       do
979         name' <- lookupOccRn (hsTyVarName tyvar)
980         return $ L l (replaceTyVarName tyvar name')
981
982     -- Type variable may only occur once.
983     --
984     checkForDups [] = return ()
985     checkForDups (L loc tv:ltvs) = 
986       do { setSrcSpan loc $
987              when (hsTyVarName tv `ltvElem` ltvs) $
988                addErr (repeatedTyVar tv)
989          ; checkForDups ltvs
990          }
991
992     _       `ltvElem` [] = False
993     rdrName `ltvElem` (L _ tv:ltvs)
994       | rdrName == hsTyVarName tv = True
995       | otherwise                 = rdrName `ltvElem` ltvs
996
997 deprecRecSyntax :: ConDecl RdrName -> SDoc
998 deprecRecSyntax decl 
999   = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_name decl))
1000                  <+> ptext (sLit "uses deprecated syntax")
1001          , ptext (sLit "Instead, use the form")
1002          , nest 2 (ppr decl) ]   -- Pretty printer uses new form
1003
1004 badRecResTy :: SDoc -> SDoc
1005 badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
1006
1007 noPatterns :: SDoc
1008 noPatterns = text "Default definition for an associated synonym cannot have"
1009              <+> text "type pattern"
1010
1011 repeatedTyVar :: HsTyVarBndr RdrName -> SDoc
1012 repeatedTyVar tv = ptext (sLit "Illegal repeated type variable") <+>
1013                    quotes (ppr tv)
1014
1015 -- This data decl will parse OK
1016 --      data T = a Int
1017 -- treating "a" as the constructor.
1018 -- It is really hard to make the parser spot this malformation.
1019 -- So the renamer has to check that the constructor is legal
1020 --
1021 -- We can get an operator as the constructor, even in the prefix form:
1022 --      data T = :% Int Int
1023 -- from interface files, which always print in prefix form
1024
1025 checkConName :: RdrName -> TcRn ()
1026 checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
1027
1028 badDataCon :: RdrName -> SDoc
1029 badDataCon name
1030    = hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)]
1031 \end{code}
1032
1033
1034 %*********************************************************
1035 %*                                                      *
1036 \subsection{Support code for type/data declarations}
1037 %*                                                      *
1038 %*********************************************************
1039
1040 Get the mapping from constructors to fields for this module.
1041 It's convenient to do this after the data type decls have been renamed
1042 \begin{code}
1043 extendRecordFieldEnv :: [LTyClDecl RdrName] -> [LInstDecl RdrName] -> TcM TcGblEnv
1044 extendRecordFieldEnv tycl_decls inst_decls
1045   = do  { tcg_env <- getGblEnv
1046         ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
1047         ; return (tcg_env { tcg_field_env = field_env' }) }
1048   where
1049     -- we want to lookup:
1050     --  (a) a datatype constructor
1051     --  (b) a record field
1052     -- knowing that they're from this module.
1053     -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn,
1054     -- which keeps only the local ones.
1055     lookup x = do { x' <- lookupLocatedTopBndrRn x
1056                     ; return $ unLoc x'}
1057
1058     all_data_cons :: [ConDecl RdrName]
1059     all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls
1060                          , L _ con <- cons ]
1061     all_tycl_decls = at_tycl_decls ++ tycl_decls
1062     at_tycl_decls = instDeclATs inst_decls  -- Do not forget associated types!
1063
1064     get_con (ConDecl { con_name = con, con_details = RecCon flds })
1065             (RecFields env fld_set)
1066         = do { con' <- lookup con
1067              ; flds' <- mapM lookup (map cd_fld_name flds)
1068              ; let env'    = extendNameEnv env con' flds'
1069                    fld_set' = addListToNameSet fld_set flds'
1070              ; return $ (RecFields env' fld_set') }
1071     get_con _ env = return env
1072 \end{code}
1073
1074 %*********************************************************
1075 %*                                                      *
1076 \subsection{Support code to rename types}
1077 %*                                                      *
1078 %*********************************************************
1079
1080 \begin{code}
1081 rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
1082
1083 rnFds doc fds
1084   = mapM (wrapLocM rn_fds) fds
1085   where
1086     rn_fds (tys1, tys2)
1087       = rnHsTyVars doc tys1             `thenM` \ tys1' ->
1088         rnHsTyVars doc tys2             `thenM` \ tys2' ->
1089         return (tys1', tys2')
1090
1091 rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name]
1092 rnHsTyVars doc tvs  = mapM (rnHsTyVar doc) tvs
1093
1094 rnHsTyVar :: SDoc -> RdrName -> RnM Name
1095 rnHsTyVar _doc tyvar = lookupOccRn tyvar
1096 \end{code}
1097
1098
1099 %*********************************************************
1100 %*                                                      *
1101         findSplice
1102 %*                                                      *
1103 %*********************************************************
1104
1105 This code marches down the declarations, looking for the first
1106 Template Haskell splice.  As it does so it
1107         a) groups the declarations into a HsGroup
1108         b) runs any top-level quasi-quotes
1109
1110 \begin{code}
1111 findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1112 findSplice ds = addl emptyRdrGroup ds
1113
1114 addl :: HsGroup RdrName -> [LHsDecl RdrName]
1115      -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1116 -- This stuff reverses the declarations (again) but it doesn't matter
1117 addl gp []           = return (gp, Nothing)
1118 addl gp (L l d : ds) = add gp l d ds
1119
1120
1121 add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName]
1122     -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1123
1124 add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds 
1125   = do { -- We've found a top-level splice.  If it is an *implicit* one 
1126          -- (i.e. a naked top level expression)
1127          case flag of
1128            Explicit -> return ()
1129            Implicit -> do { th_on <- doptM Opt_TemplateHaskell
1130                           ; unless th_on $ setSrcSpan loc $
1131                             failWith badImplicitSplice }
1132
1133        ; return (gp, Just (splice, ds)) }
1134   where
1135     badImplicitSplice = ptext (sLit "Parse error: naked expression at top level")
1136
1137 #ifndef GHCI
1138 add _ _ (QuasiQuoteD qq) _
1139   = pprPanic "Can't do QuasiQuote declarations without GHCi" (ppr qq)
1140 #else
1141 add gp _ (QuasiQuoteD qq) ds            -- Expand quasiquotes
1142   = do { ds' <- runQuasiQuoteDecl qq
1143        ; addl gp (ds' ++ ds) }
1144 #endif
1145
1146 -- Class declarations: pull out the fixity signatures to the top
1147 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
1148   | isClassDecl d
1149   = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
1150     addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
1151   | otherwise
1152   = addl (gp { hs_tyclds = L l d : ts }) ds
1153
1154 -- Signatures: fixity sigs go a different place than all others
1155 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
1156   = addl (gp {hs_fixds = L l f : ts}) ds
1157 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
1158   = addl (gp {hs_valds = add_sig (L l d) ts}) ds
1159
1160 -- Value declarations: use add_bind
1161 add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
1162   = addl (gp { hs_valds = add_bind (L l d) ts }) ds
1163
1164 -- The rest are routine
1165 add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
1166   = addl (gp { hs_instds = L l d : ts }) ds
1167 add gp@(HsGroup {hs_derivds = ts})  l (DerivD d) ds
1168   = addl (gp { hs_derivds = L l d : ts }) ds
1169 add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
1170   = addl (gp { hs_defds = L l d : ts }) ds
1171 add gp@(HsGroup {hs_fords  = ts}) l (ForD d) ds
1172   = addl (gp { hs_fords = L l d : ts }) ds
1173 add gp@(HsGroup {hs_warnds  = ts})  l (WarningD d) ds
1174   = addl (gp { hs_warnds = L l d : ts }) ds
1175 add gp@(HsGroup {hs_annds  = ts}) l (AnnD d) ds
1176   = addl (gp { hs_annds = L l d : ts }) ds
1177 add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
1178   = addl (gp { hs_ruleds = L l d : ts }) ds
1179 add gp l (DocD d) ds
1180   = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds
1181
1182 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
1183 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
1184 add_bind _ (ValBindsOut {})     = panic "RdrHsSyn:add_bind"
1185
1186 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
1187 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) 
1188 add_sig _ (ValBindsOut {})     = panic "RdrHsSyn:add_sig"
1189 \end{code}