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