do not link with -lrt on Solaris for threaded way
[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 {-# LANGUAGE CPP, ScopedTypeVariables #-}
8
9 module RnSource (
10         rnSrcDecls, addTcgDUs, rnTyClDecls, findSplice
11     ) where
12
13 #include "HsVersions.h"
14
15 import {-# SOURCE #-} RnExpr( rnLExpr )
16 import {-# SOURCE #-} RnSplice ( rnSpliceDecl )
17 import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl )
18
19 import HsSyn
20 import RdrName
21 import RnTypes
22 import RnBinds
23 import RnEnv
24 import RnNames
25 import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
26 import TcAnnotations    ( annCtxt )
27 import TcRnMonad
28
29 import ForeignCall      ( CCallTarget(..) )
30 import Module
31 import HscTypes         ( Warnings(..), plusWarns )
32 import Class            ( FunDep )
33 import PrelNames        ( isUnboundName )
34 import Name
35 import NameSet
36 import NameEnv
37 import Avail
38 import Outputable
39 import Bag
40 import BasicTypes       ( RuleName )
41 import FastString
42 import SrcLoc
43 import DynFlags
44 import HscTypes         ( HscEnv, hsc_dflags )
45 import ListSetOps       ( findDupsEq, removeDups )
46 import Digraph          ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
47 import Util             ( mapSnd )
48
49 import Control.Monad
50 import Data.List( partition, sortBy )
51 import Data.Traversable (traverse)
52 import Maybes( orElse, mapMaybe )
53 \end{code}
54
55 @rnSourceDecl@ `renames' declarations.
56 It simultaneously performs dependency analysis and precedence parsing.
57 It also does the following error checks:
58 \begin{enumerate}
59 \item
60 Checks that tyvars are used properly. This includes checking
61 for undefined tyvars, and tyvars in contexts that are ambiguous.
62 (Some of this checking has now been moved to module @TcMonoType@,
63 since we don't have functional dependency information at this point.)
64 \item
65 Checks that all variable occurrences are defined.
66 \item
67 Checks the @(..)@ etc constraints in the export list.
68 \end{enumerate}
69
70
71 \begin{code}
72 -- Brings the binders of the group into scope in the appropriate places;
73 -- does NOT assume that anything is in scope already
74 rnSrcDecls :: [Name] -> HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
75 -- Rename a HsGroup; used for normal source files *and* hs-boot files
76 rnSrcDecls extra_deps group@(HsGroup { hs_valds   = val_decls,
77                                        hs_splcds  = splice_decls,
78                                        hs_tyclds  = tycl_decls,
79                                        hs_instds  = inst_decls,
80                                        hs_derivds = deriv_decls,
81                                        hs_fixds   = fix_decls,
82                                        hs_warnds  = warn_decls,
83                                        hs_annds   = ann_decls,
84                                        hs_fords   = foreign_decls,
85                                        hs_defds   = default_decls,
86                                        hs_ruleds  = rule_decls,
87                                        hs_vects   = vect_decls,
88                                        hs_docs    = docs })
89  = do {
90    -- (A) Process the fixity declarations, creating a mapping from
91    --     FastStrings to FixItems.
92    --     Also checks for duplcates.
93    local_fix_env <- makeMiniFixityEnv fix_decls ;
94
95    -- (B) Bring top level binders (and their fixities) into scope,
96    --     *except* for the value bindings, which get brought in below.
97    --     However *do* include class ops, data constructors
98    --     And for hs-boot files *do* include the value signatures
99    (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;
100    setEnvs tc_envs $ do {
101
102    failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
103
104    -- (C) Extract the mapping from data constructors to field names and
105    --     extend the record field env.
106    --     This depends on the data constructors and field names being in
107    --     scope from (B) above
108    inNewEnv (extendRecordFieldEnv tycl_decls inst_decls) $ \ _ -> do {
109
110    -- (D) Rename the left-hand sides of the value bindings.
111    --     This depends on everything from (B) being in scope,
112    --     and on (C) for resolving record wild cards.
113    --     It uses the fixity env from (A) to bind fixities for view patterns.
114    new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
115    -- bind the LHSes (and their fixities) in the global rdr environment
116    let { val_binders = collectHsValBinders new_lhs ;
117          all_bndrs   = addListToNameSet tc_bndrs val_binders ;
118          val_avails  = map Avail val_binders  } ;
119    traceRn (text "rnSrcDecls" <+> ppr val_avails) ;
120    (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ;
121    traceRn (ptext (sLit "Val binders") <+> (ppr val_binders)) ;
122    setEnvs (tcg_env, tcl_env) $ do {
123
124    --  Now everything is in scope, as the remaining renaming assumes.
125
126    -- (E) Rename type and class decls
127    --     (note that value LHSes need to be in scope for default methods)
128    --
129    -- You might think that we could build proper def/use information
130    -- for type and class declarations, but they can be involved
131    -- in mutual recursion across modules, and we only do the SCC
132    -- analysis for them in the type checker.
133    -- So we content ourselves with gathering uses only; that
134    -- means we'll only report a declaration as unused if it isn't
135    -- mentioned at all.  Ah well.
136    traceRn (text "Start rnTyClDecls") ;
137    (rn_tycl_decls, src_fvs1) <- rnTyClDecls extra_deps tycl_decls ;
138
139    -- (F) Rename Value declarations right-hand sides
140    traceRn (text "Start rnmono") ;
141    (rn_val_decls, bind_dus) <- rnTopBindsRHS all_bndrs new_lhs ;
142    traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
143
144    -- (G) Rename Fixity and deprecations
145
146    -- Rename fixity declarations and error if we try to
147    -- fix something from another module (duplicates were checked in (A))
148    rn_fix_decls <- rnSrcFixityDecls all_bndrs fix_decls ;
149
150    -- Rename deprec decls;
151    -- check for duplicates and ensure that deprecated things are defined locally
152    -- at the moment, we don't keep these around past renaming
153    rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ;
154
155    -- (H) Rename Everything else
156
157    (rn_inst_decls,    src_fvs2) <- rnList rnSrcInstDecl   inst_decls ;
158    (rn_rule_decls,    src_fvs3) <- setXOptM Opt_ScopedTypeVariables $
159                                    rnList rnHsRuleDecl    rule_decls ;
160                            -- Inside RULES, scoped type variables are on
161    (rn_vect_decls,    src_fvs4) <- rnList rnHsVectDecl    vect_decls ;
162    (rn_foreign_decls, src_fvs5) <- rnList rnHsForeignDecl foreign_decls ;
163    (rn_ann_decls,     src_fvs6) <- rnList rnAnnDecl       ann_decls ;
164    (rn_default_decls, src_fvs7) <- rnList rnDefaultDecl   default_decls ;
165    (rn_deriv_decls,   src_fvs8) <- rnList rnSrcDerivDecl  deriv_decls ;
166    (rn_splice_decls,  src_fvs9) <- rnList rnSpliceDecl    splice_decls ;
167       -- Haddock docs; no free vars
168    rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
169
170     last_tcg_env <- getGblEnv ;
171    -- (I) Compute the results and return
172    let {rn_group = HsGroup { hs_valds   = rn_val_decls,
173                              hs_splcds  = rn_splice_decls,
174                              hs_tyclds  = rn_tycl_decls,
175                              hs_instds  = rn_inst_decls,
176                              hs_derivds = rn_deriv_decls,
177                              hs_fixds   = rn_fix_decls,
178                              hs_warnds  = [], -- warns are returned in the tcg_env
179                                              -- (see below) not in the HsGroup
180                              hs_fords  = rn_foreign_decls,
181                              hs_annds  = rn_ann_decls,
182                              hs_defds  = rn_default_decls,
183                              hs_ruleds = rn_rule_decls,
184                              hs_vects  = rn_vect_decls,
185                              hs_docs   = rn_docs } ;
186
187         tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ;
188         ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ;
189         other_def  = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ;
190         other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
191                               src_fvs5, src_fvs6, src_fvs7, src_fvs8,
192                               src_fvs9] ;
193                 -- It is tiresome to gather the binders from type and class decls
194
195         src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
196                 -- Instance decls may have occurrences of things bound in bind_dus
197                 -- so we must put other_fvs last
198
199         final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus)
200                         in -- we return the deprecs in the env, not in the HsGroup above
201                         tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
202        } ;
203
204    traceRn (text "finish rnSrc" <+> ppr rn_group) ;
205    traceRn (text "finish Dus" <+> ppr src_dus ) ;
206    return (final_tcg_env, rn_group)
207                     }}}}
208
209 -- some utils because we do this a bunch above
210 -- compute and install the new env
211 inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a
212 inNewEnv env cont = do e <- env
213                        setGblEnv e $ cont e
214
215 addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
216 -- This function could be defined lower down in the module hierarchy,
217 -- but there doesn't seem anywhere very logical to put it.
218 addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
219
220 rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
221 rnList f xs = mapFvRn (wrapLocFstM f) xs
222 \end{code}
223
224
225 %*********************************************************
226 %*                                                       *
227         HsDoc stuff
228 %*                                                       *
229 %*********************************************************
230
231 \begin{code}
232 rnDocDecl :: DocDecl -> RnM DocDecl
233 rnDocDecl (DocCommentNext doc) = do
234   rn_doc <- rnHsDoc doc
235   return (DocCommentNext rn_doc)
236 rnDocDecl (DocCommentPrev doc) = do
237   rn_doc <- rnHsDoc doc
238   return (DocCommentPrev rn_doc)
239 rnDocDecl (DocCommentNamed str doc) = do
240   rn_doc <- rnHsDoc doc
241   return (DocCommentNamed str rn_doc)
242 rnDocDecl (DocGroup lev doc) = do
243   rn_doc <- rnHsDoc doc
244   return (DocGroup lev rn_doc)
245 \end{code}
246
247
248 %*********************************************************
249 %*                                                       *
250         Source-code fixity declarations
251 %*                                                       *
252 %*********************************************************
253
254 \begin{code}
255 rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name]
256 -- Rename the fixity decls, so we can put
257 -- the renamed decls in the renamed syntax tree
258 -- Errors if the thing being fixed is not defined locally.
259 --
260 -- The returned FixitySigs are not actually used for anything,
261 -- except perhaps the GHCi API
262 rnSrcFixityDecls bndr_set fix_decls
263   = do fix_decls <- mapM rn_decl fix_decls
264        return (concat fix_decls)
265   where
266     sig_ctxt = TopSigCtxt bndr_set True
267        -- True <=> can give fixity for class decls and record selectors
268
269     rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]
270         -- GHC extension: look up both the tycon and data con
271         -- for con-like things; hence returning a list
272         -- If neither are in scope, report an error; otherwise
273         -- return a fixity sig for each (slightly odd)
274     rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity))
275       = setSrcSpan name_loc $
276                     -- this lookup will fail if the definition isn't local
277         do names <- lookupLocalTcNames sig_ctxt what rdr_name
278            return [ L loc (FixitySig (L name_loc name) fixity)
279                   | name <- names ]
280     what = ptext (sLit "fixity signature")
281 \end{code}
282
283
284 %*********************************************************
285 %*                                                       *
286         Source-code deprecations declarations
287 %*                                                       *
288 %*********************************************************
289
290 Check that the deprecated names are defined, are defined locally, and
291 that there are no duplicate deprecations.
292
293 It's only imported deprecations, dealt with in RnIfaces, that we
294 gather them together.
295
296 \begin{code}
297 -- checks that the deprecations are defined locally, and that there are no duplicates
298 rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings
299 rnSrcWarnDecls _ []
300   = return NoWarnings
301
302 rnSrcWarnDecls bndr_set decls
303   = do { -- check for duplicates
304        ; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups
305                           in addErrAt loc (dupWarnDecl lrdr' rdr))
306                warn_rdr_dups
307        ; pairs_s <- mapM (addLocM rn_deprec) decls
308        ; return (WarnSome ((concat pairs_s))) }
309  where
310    sig_ctxt = TopSigCtxt bndr_set True
311       -- True <=> Can give deprecations for class ops and record sels
312
313    rn_deprec (Warning rdr_name txt)
314        -- ensures that the names are defined locally
315      = do { names <- lookupLocalTcNames sig_ctxt what rdr_name
316           ; return [(nameOccName name, txt) | name <- names] }
317
318    what = ptext (sLit "deprecation")
319
320    warn_rdr_dups = findDupRdrNames (map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls)
321
322 findDupRdrNames :: [Located RdrName] -> [[Located RdrName]]
323 findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
324
325 -- look for duplicates among the OccNames;
326 -- we check that the names are defined above
327 -- invt: the lists returned by findDupsEq always have at least two elements
328
329 dupWarnDecl :: Located RdrName -> RdrName -> SDoc
330 -- Located RdrName -> DeprecDecl RdrName -> SDoc
331 dupWarnDecl (L loc _) rdr_name
332   = vcat [ptext (sLit "Multiple warning declarations for") <+> quotes (ppr rdr_name),
333           ptext (sLit "also at ") <+> ppr loc]
334
335 \end{code}
336
337 %*********************************************************
338 %*                                                      *
339 \subsection{Annotation declarations}
340 %*                                                      *
341 %*********************************************************
342
343 \begin{code}
344 rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars)
345 rnAnnDecl ann@(HsAnnotation provenance expr)
346   = addErrCtxt (annCtxt ann) $
347     do { (provenance', provenance_fvs) <- rnAnnProvenance provenance
348        ; (expr', expr_fvs) <- setStage (Splice False) $
349                               rnLExpr expr
350        ; return (HsAnnotation provenance' expr', provenance_fvs `plusFV` expr_fvs) }
351
352 rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars)
353 rnAnnProvenance provenance = do
354     provenance' <- traverse lookupTopBndrRn provenance
355     return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))
356 \end{code}
357
358 %*********************************************************
359 %*                                                      *
360 \subsection{Default declarations}
361 %*                                                      *
362 %*********************************************************
363
364 \begin{code}
365 rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars)
366 rnDefaultDecl (DefaultDecl tys)
367   = do { (tys', fvs) <- rnLHsTypes doc_str tys
368        ; return (DefaultDecl tys', fvs) }
369   where
370     doc_str = DefaultDeclCtx
371 \end{code}
372
373 %*********************************************************
374 %*                                                      *
375 \subsection{Foreign declarations}
376 %*                                                      *
377 %*********************************************************
378
379 \begin{code}
380 rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
381 rnHsForeignDecl (ForeignImport name ty _ spec)
382   = do { topEnv :: HscEnv <- getTopEnv
383        ; name' <- lookupLocatedTopBndrRn name
384        ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty
385
386         -- Mark any PackageTarget style imports as coming from the current package
387        ; let packageKey = thisPackage $ hsc_dflags topEnv
388              spec'      = patchForeignImport packageKey spec
389
390        ; return (ForeignImport name' ty' noForeignImportCoercionYet spec', fvs) }
391
392 rnHsForeignDecl (ForeignExport name ty _ spec)
393   = do { name' <- lookupLocatedOccRn name
394        ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty
395        ; return (ForeignExport name' ty' noForeignExportCoercionYet spec, fvs `addOneFV` unLoc name') }
396         -- NB: a foreign export is an *occurrence site* for name, so
397         --     we add it to the free-variable list.  It might, for example,
398         --     be imported from another module
399
400 -- | For Windows DLLs we need to know what packages imported symbols are from
401 --      to generate correct calls. Imported symbols are tagged with the current
402 --      package, so if they get inlined across a package boundry we'll still
403 --      know where they're from.
404 --
405 patchForeignImport :: PackageKey -> ForeignImport -> ForeignImport
406 patchForeignImport packageKey (CImport cconv safety fs spec)
407         = CImport cconv safety fs (patchCImportSpec packageKey spec)
408
409 patchCImportSpec :: PackageKey -> CImportSpec -> CImportSpec
410 patchCImportSpec packageKey spec
411  = case spec of
412         CFunction callTarget    -> CFunction $ patchCCallTarget packageKey callTarget
413         _                       -> spec
414
415 patchCCallTarget :: PackageKey -> CCallTarget -> CCallTarget
416 patchCCallTarget packageKey callTarget =
417   case callTarget of
418   StaticTarget label Nothing isFun -> StaticTarget label (Just packageKey) isFun
419   _                                -> callTarget
420
421
422 \end{code}
423
424
425 %*********************************************************
426 %*                                                      *
427 \subsection{Instance declarations}
428 %*                                                      *
429 %*********************************************************
430
431 \begin{code}
432 rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
433 rnSrcInstDecl (TyFamInstD { tfid_inst = tfi }) 
434   = do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi
435        ; return (TyFamInstD { tfid_inst = tfi' }, fvs) }
436
437 rnSrcInstDecl (DataFamInstD { dfid_inst = dfi }) 
438   = do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi
439        ; return (DataFamInstD { dfid_inst = dfi' }, fvs) }
440
441 rnSrcInstDecl (ClsInstD { cid_inst = cid })
442   = do { (cid', fvs) <- rnClsInstDecl cid
443        ; return (ClsInstD { cid_inst = cid' }, fvs) }
444
445 rnClsInstDecl :: ClsInstDecl RdrName -> RnM (ClsInstDecl Name, FreeVars)
446 rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
447                            , cid_sigs = uprags, cid_tyfam_insts = ats
448                            , cid_overlap_mode = oflag
449                            , cid_datafam_insts = adts })
450         -- Used for both source and interface file decls
451   = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty
452        ; case splitLHsInstDeclTy_maybe inst_ty' of {
453            Nothing -> return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds
454                                           , cid_sigs = [], cid_tyfam_insts = []
455                                           , cid_overlap_mode = oflag
456                                           , cid_datafam_insts = [] }
457                              , inst_fvs) ;
458            Just (inst_tyvars, _, L _ cls,_) ->
459
460     do { let (spec_inst_prags, other_sigs) = partition isSpecInstLSig uprags
461              ktv_names = hsLKiTyVarNames inst_tyvars
462
463        -- Rename the associated types, and type signatures
464        -- Both need to have the instance type variables in scope
465        ; traceRn (text "rnSrcInstDecl"  <+> ppr inst_ty' $$ ppr inst_tyvars $$ ppr ktv_names)
466        ; ((ats', adts', other_sigs'), more_fvs) 
467              <- extendTyVarEnvFVRn ktv_names $
468                 do { (ats',  at_fvs)  <- rnATInstDecls rnTyFamInstDecl cls inst_tyvars ats
469                    ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls inst_tyvars adts
470                    ; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs
471                    ; return ( (ats', adts', other_sigs')
472                             , at_fvs `plusFV` adt_fvs `plusFV` sig_fvs) }
473
474         -- Rename the bindings
475         -- The typechecker (not the renamer) checks that all
476         -- the bindings are for the right class
477         -- (Slightly strangely) when scoped type variables are on, the
478         -- forall-d tyvars scope over the method bindings too
479        ; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds ktv_names $
480                                 rnMethodBinds cls (mkSigTvFn other_sigs')
481                                                   mbinds
482
483         -- Rename the SPECIALISE instance pramas
484         -- Annoyingly the type variables are not in scope here,
485         -- so that      instance Eq a => Eq (T a) where
486         --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
487         -- works OK. That's why we did the partition game above
488         --
489        ; (spec_inst_prags', spec_inst_fvs)
490              <- renameSigs (InstDeclCtxt cls) spec_inst_prags
491
492        ; let uprags' = spec_inst_prags' ++ other_sigs'
493              all_fvs = meth_fvs `plusFV` more_fvs
494                           `plusFV` spec_inst_fvs
495                           `plusFV` inst_fvs
496        ; return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = mbinds'
497                              , cid_sigs = uprags', cid_tyfam_insts = ats'
498                              , cid_overlap_mode = oflag
499                              , cid_datafam_insts = adts' },
500                  all_fvs) } } }
501              -- We return the renamed associated data type declarations so
502              -- that they can be entered into the list of type declarations
503              -- for the binding group, but we also keep a copy in the instance.
504              -- The latter is needed for well-formedness checks in the type
505              -- checker (eg, to ensure that all ATs of the instance actually
506              -- receive a declaration).
507              -- NB: Even the copies in the instance declaration carry copies of
508              --     the instance context after renaming.  This is a bit
509              --     strange, but should not matter (and it would be more work
510              --     to remove the context).
511
512 rnFamInstDecl :: HsDocContext
513               -> Maybe (Name, [Name])
514               -> Located RdrName
515               -> [LHsType RdrName]
516               -> rhs
517               -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
518               -> RnM (Located Name, HsWithBndrs [LHsType Name], rhs', FreeVars)
519 rnFamInstDecl doc mb_cls tycon pats payload rnPayload
520   = do { tycon'   <- lookupFamInstName (fmap fst mb_cls) tycon
521        ; let loc = case pats of
522                      []             -> pprPanic "rnFamInstDecl" (ppr tycon)
523                      (L loc _ : []) -> loc
524                      (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
525              (kv_rdr_names, tv_rdr_names) = extractHsTysRdrTyVars pats
526
527
528        ; rdr_env  <- getLocalRdrEnv
529        ; kv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) kv_rdr_names
530        ; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names
531              -- All the free vars of the family patterns
532              -- with a sensible binding location
533        ; ((pats', payload'), fvs) 
534               <- bindLocalNamesFV kv_names $ 
535                  bindLocalNamesFV tv_names $ 
536                  do { (pats', pat_fvs) <- rnLHsTypes doc pats
537                     ; (payload', rhs_fvs) <- rnPayload doc payload
538
539                          -- See Note [Renaming associated types]
540                     ; let bad_tvs = case mb_cls of
541                                       Nothing          -> []
542                                       Just (_,cls_tvs) -> filter is_bad cls_tvs
543                           is_bad tv = not (tv `elem` tv_names) && tv `elemNameSet` rhs_fvs
544
545                     ; unless (null bad_tvs) (badAssocRhs bad_tvs)
546                     ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) }
547                               
548
549        ; let all_fvs = fvs `addOneFV` unLoc tycon'
550        ; return (tycon',
551                  HsWB { hswb_cts = pats', hswb_kvs = kv_names, hswb_tvs = tv_names },
552                  payload',
553                  all_fvs) }
554              -- type instance => use, hence addOneFV
555
556 rnTyFamInstDecl :: Maybe (Name, [Name])
557                 -> TyFamInstDecl RdrName
558                 -> RnM (TyFamInstDecl Name, FreeVars)
559 rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = L loc eqn })
560   = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn
561        ; return (TyFamInstDecl { tfid_eqn = L loc eqn'
562                                , tfid_fvs = fvs }, fvs) }
563
564 rnTyFamInstEqn :: Maybe (Name, [Name])
565                -> TyFamInstEqn RdrName
566                -> RnM (TyFamInstEqn Name, FreeVars)
567 rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon
568                                 , tfe_pats  = HsWB { hswb_cts = pats }
569                                 , tfe_rhs   = rhs })
570   = do { (tycon', pats', rhs', fvs) <-
571            rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn
572        ; return (TyFamEqn { tfe_tycon = tycon'
573                           , tfe_pats  = pats'
574                           , tfe_rhs   = rhs' }, fvs) }
575
576 rnTyFamDefltEqn :: Name
577                 -> TyFamDefltEqn RdrName
578                 -> RnM (TyFamDefltEqn Name, FreeVars)
579 rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon
580                               , tfe_pats  = tyvars
581                               , tfe_rhs   = rhs })
582   = bindHsTyVars ctx (Just cls) [] tyvars $ \ tyvars' ->
583     do { tycon'      <- lookupFamInstName (Just cls) tycon
584        ; (rhs', fvs) <- rnLHsType ctx rhs
585        ; return (TyFamEqn { tfe_tycon = tycon'
586                           , tfe_pats  = tyvars'
587                           , tfe_rhs   = rhs' }, fvs) }
588   where
589     ctx = TyFamilyCtx tycon
590
591 rnDataFamInstDecl :: Maybe (Name, [Name])
592                   -> DataFamInstDecl RdrName
593                   -> RnM (DataFamInstDecl Name, FreeVars)
594 rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon
595                                           , dfid_pats  = HsWB { hswb_cts = pats }
596                                           , dfid_defn  = defn })
597   = do { (tycon', pats', defn', fvs) <-
598            rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn
599        ; return (DataFamInstDecl { dfid_tycon = tycon'
600                                  , dfid_pats  = pats'
601                                  , dfid_defn  = defn'
602                                  , dfid_fvs   = fvs }, fvs) }
603 \end{code}
604
605 Renaming of the associated types in instances.
606
607 \begin{code}
608 -- Rename associated type family decl in class
609 rnATDecls :: Name      -- Class
610           -> [LFamilyDecl RdrName] 
611           -> RnM ([LFamilyDecl Name], FreeVars)
612 rnATDecls cls at_decls
613   = rnList (rnFamDecl (Just cls)) at_decls
614
615 rnATInstDecls :: (Maybe (Name, [Name]) ->    -- The function that renames
616                   decl RdrName ->            -- an instance. rnTyFamInstDecl
617                   RnM (decl Name, FreeVars)) -- or rnDataFamInstDecl
618               -> Name      -- Class
619               -> LHsTyVarBndrs Name
620               -> [Located (decl RdrName)] 
621               -> RnM ([Located (decl Name)], FreeVars)
622 -- Used for data and type family defaults in a class decl
623 -- and the family instance declarations in an instance
624 --
625 -- NB: We allow duplicate associated-type decls;
626 --     See Note [Associated type instances] in TcInstDcls
627 rnATInstDecls rnFun cls hs_tvs at_insts
628   = rnList (rnFun (Just (cls, tv_ns))) at_insts
629   where
630     tv_ns = hsLTyVarNames hs_tvs
631     -- Type variable binders (but NOT kind variables)
632     -- See Note [Renaming associated types] in RnTypes
633 \end{code}
634
635 For the method bindings in class and instance decls, we extend the
636 type variable environment iff -fglasgow-exts
637
638 \begin{code}
639 extendTyVarEnvForMethodBinds :: [Name]
640                              -> RnM (LHsBinds Name, FreeVars)
641                              -> RnM (LHsBinds Name, FreeVars)
642 extendTyVarEnvForMethodBinds ktv_names thing_inside
643   = do  { scoped_tvs <- xoptM Opt_ScopedTypeVariables
644         ; if scoped_tvs then
645                 extendTyVarEnvFVRn ktv_names thing_inside
646           else
647                 thing_inside }
648 \end{code}
649
650 %*********************************************************
651 %*                                                      *
652 \subsection{Stand-alone deriving declarations}
653 %*                                                      *
654 %*********************************************************
655
656 \begin{code}
657 rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
658 rnSrcDerivDecl (DerivDecl ty overlap)
659   = do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving
660        ; unless standalone_deriv_ok (addErr standaloneDerivErr)
661        ; (ty', fvs) <- rnLHsInstType (text "In a deriving declaration") ty
662        ; return (DerivDecl ty' overlap, fvs) }
663
664 standaloneDerivErr :: SDoc
665 standaloneDerivErr
666   = hang (ptext (sLit "Illegal standalone deriving declaration"))
667        2 (ptext (sLit "Use StandaloneDeriving to enable this extension"))
668 \end{code}
669
670 %*********************************************************
671 %*                                                      *
672 \subsection{Rules}
673 %*                                                      *
674 %*********************************************************
675
676 \begin{code}
677 rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
678 rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
679   = do { let rdr_names_w_loc = map get_var vars
680        ; checkDupRdrNames rdr_names_w_loc
681        ; checkShadowedRdrNames rdr_names_w_loc
682        ; names <- newLocalBndrsRn rdr_names_w_loc
683        ; bindHsRuleVars rule_name vars names $ \ vars' ->
684     do { (lhs', fv_lhs') <- rnLExpr lhs
685        ; (rhs', fv_rhs') <- rnLExpr rhs
686        ; checkValidRule rule_name names lhs' fv_lhs'
687        ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
688                  fv_lhs' `plusFV` fv_rhs') } }
689   where
690     get_var (RuleBndrSig v _) = v
691     get_var (RuleBndr v) = v
692
693 bindHsRuleVars :: RuleName -> [RuleBndr RdrName] -> [Name]
694                -> ([RuleBndr Name] -> RnM (a, FreeVars))
695                -> RnM (a, FreeVars)
696 bindHsRuleVars rule_name vars names thing_inside
697   = go vars names $ \ vars' ->
698     bindLocalNamesFV names (thing_inside vars')
699   where
700     doc = RuleCtx rule_name
701
702     go (RuleBndr (L loc _) : vars) (n : ns) thing_inside
703       = go vars ns $ \ vars' ->
704         thing_inside (RuleBndr (L loc n) : vars')
705
706     go (RuleBndrSig (L loc _) bsig : vars) (n : ns) thing_inside
707       = rnHsBndrSig doc bsig $ \ bsig' ->
708         go vars ns $ \ vars' ->
709         thing_inside (RuleBndrSig (L loc n) bsig' : vars')
710
711     go [] [] thing_inside = thing_inside []
712     go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
713 \end{code}
714
715 Note [Rule LHS validity checking]
716 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
717 Check the shape of a transformation rule LHS.  Currently we only allow
718 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
719 @forall@'d variables.
720
721 We used restrict the form of the 'ei' to prevent you writing rules
722 with LHSs with a complicated desugaring (and hence unlikely to match);
723 (e.g. a case expression is not allowed: too elaborate.)
724
725 But there are legitimate non-trivial args ei, like sections and
726 lambdas.  So it seems simmpler not to check at all, and that is why
727 check_e is commented out.
728
729 \begin{code}
730 checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM ()
731 checkValidRule rule_name ids lhs' fv_lhs'
732   = do  {       -- Check for the form of the LHS
733           case (validRuleLhs ids lhs') of
734                 Nothing  -> return ()
735                 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
736
737                 -- Check that LHS vars are all bound
738         ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
739         ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
740
741 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
742 -- Nothing => OK
743 -- Just e  => Not ok, and e is the offending expression
744 validRuleLhs foralls lhs
745   = checkl lhs
746   where
747     checkl (L _ e) = check e
748
749     check (OpApp e1 op _ e2)              = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
750     check (HsApp e1 e2)                   = checkl e1 `mplus` checkl_e e2
751     check (HsVar v) | v `notElem` foralls = Nothing
752     check other                           = Just other  -- Failure
753
754         -- Check an argument
755     checkl_e (L _ _e) = Nothing         -- Was (check_e e); see Note [Rule LHS validity checking]
756
757 {-      Commented out; see Note [Rule LHS validity checking] above
758     check_e (HsVar v)     = Nothing
759     check_e (HsPar e)     = checkl_e e
760     check_e (HsLit e)     = Nothing
761     check_e (HsOverLit e) = Nothing
762
763     check_e (OpApp e1 op _ e2)   = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
764     check_e (HsApp e1 e2)        = checkl_e e1 `mplus` checkl_e e2
765     check_e (NegApp e _)         = checkl_e e
766     check_e (ExplicitList _ es)  = checkl_es es
767     check_e other                = Just other   -- Fails
768
769     checkl_es es = foldr (mplus . checkl_e) Nothing es
770 -}
771
772 badRuleVar :: FastString -> Name -> SDoc
773 badRuleVar name var
774   = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon,
775          ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+>
776                 ptext (sLit "does not appear on left hand side")]
777
778 badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
779 badRuleLhsErr name lhs bad_e
780   = sep [ptext (sLit "Rule") <+> ftext name <> colon,
781          nest 4 (vcat [ptext (sLit "Illegal expression:") <+> ppr bad_e,
782                        ptext (sLit "in left-hand side:") <+> ppr lhs])]
783     $$
784     ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd")
785 \end{code}
786
787
788 %*********************************************************
789 %*                                                      *
790 \subsection{Vectorisation declarations}
791 %*                                                      *
792 %*********************************************************
793
794 \begin{code}
795 rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars)
796 -- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly
797 --        typecheck a complex right-hand side without invoking 'vectType' from the vectoriser.
798 rnHsVectDecl (HsVect var rhs@(L _ (HsVar _)))
799   = do { var' <- lookupLocatedOccRn var
800        ; (rhs', fv_rhs) <- rnLExpr rhs
801        ; return (HsVect var' rhs', fv_rhs `addOneFV` unLoc var')
802        }
803 rnHsVectDecl (HsVect _var _rhs)
804   = failWith $ vcat 
805                [ ptext (sLit "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma")
806                , ptext (sLit "must be an identifier")
807                ]
808 rnHsVectDecl (HsNoVect var)
809   = do { var' <- lookupLocatedTopBndrRn var           -- only applies to local (not imported) names
810        ; return (HsNoVect var', unitFV (unLoc var'))
811        }
812 rnHsVectDecl (HsVectTypeIn isScalar tycon Nothing)
813   = do { tycon' <- lookupLocatedOccRn tycon
814        ; return (HsVectTypeIn isScalar tycon' Nothing, unitFV (unLoc tycon'))
815        }
816 rnHsVectDecl (HsVectTypeIn isScalar tycon (Just rhs_tycon))
817   = do { tycon'     <- lookupLocatedOccRn tycon
818        ; rhs_tycon' <- lookupLocatedOccRn rhs_tycon
819        ; return ( HsVectTypeIn isScalar tycon' (Just rhs_tycon')
820                 , mkFVs [unLoc tycon', unLoc rhs_tycon'])
821        }
822 rnHsVectDecl (HsVectTypeOut _ _ _)
823   = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'"
824 rnHsVectDecl (HsVectClassIn cls)
825   = do { cls' <- lookupLocatedOccRn cls
826        ; return (HsVectClassIn cls', unitFV (unLoc cls'))
827        }
828 rnHsVectDecl (HsVectClassOut _)
829   = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
830 rnHsVectDecl (HsVectInstIn instTy)
831   = do { (instTy', fvs) <- rnLHsInstType (text "In a VECTORISE pragma") instTy
832        ; return (HsVectInstIn instTy', fvs)
833        }
834 rnHsVectDecl (HsVectInstOut _)
835   = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"
836 \end{code}
837
838 %*********************************************************
839 %*                                                      *
840 \subsection{Type, class and iface sig declarations}
841 %*                                                      *
842 %*********************************************************
843
844 @rnTyDecl@ uses the `global name function' to create a new type
845 declaration in which local names have been replaced by their original
846 names, reporting any unknown names.
847
848 Renaming type variables is a pain. Because they now contain uniques,
849 it is necessary to pass in an association list which maps a parsed
850 tyvar to its @Name@ representation.
851 In some cases (type signatures of values),
852 it is even necessary to go over the type first
853 in order to get the set of tyvars used by it, make an assoc list,
854 and then go over it again to rename the tyvars!
855 However, we can also do some scoping checks at the same time.
856
857
858 Note [Extra dependencies from .hs-boot files]
859 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
860 Consider the following case:
861
862   module A where
863     import B
864     data A1 = A1 B1
865
866   module B where
867     import {-# SOURCE #-} A
868     type DisguisedA1 = A1
869     data B1 = B1 DisguisedA1
870
871 We do not follow type synonyms when building the dependencies for each datatype,
872 so we will not find out that B1 really depends on A1 (which means it depends on
873 itself). To handle this problem, at the moment we add dependencies to everything
874 that comes from an .hs-boot file. But we don't add those dependencies to
875 everything. Imagine module B above had another datatype declaration:
876
877   data B2 = B2 Int
878
879 Even though B2 has a dependency (on Int), all its dependencies are from things
880 that live on other packages. Since we don't have mutual dependencies across
881 packages, it is safe not to add the dependencies on the .hs-boot stuff to B2.
882
883 See also Note [Grouping of type and class declarations] in TcTyClsDecls.
884
885 \begin{code}
886 isInPackage :: PackageKey -> Name -> Bool
887 isInPackage pkgId nm = case nameModule_maybe nm of
888                          Nothing -> False
889                          Just m  -> pkgId == modulePackageKey m
890 -- We use nameModule_maybe because we might be in a TH splice, in which case
891 -- there is no module name. In that case we cannot have mutual dependencies,
892 -- so it's fine to return False here.
893
894 rnTyClDecls :: [Name] -> [TyClGroup RdrName]
895             -> RnM ([TyClGroup Name], FreeVars)
896 -- Rename the declarations and do depedency analysis on them
897 rnTyClDecls extra_deps tycl_ds
898   = do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupConcat tycl_ds)
899        ; role_annot_env <- rnRoleAnnots (concatMap group_roles tycl_ds)
900        ; thisPkg  <- fmap thisPackage getDynFlags
901        ; let add_boot_deps :: FreeVars -> FreeVars
902              -- See Note [Extra dependencies from .hs-boot files]
903              add_boot_deps fvs | any (isInPackage thisPkg) (nameSetToList fvs)
904                                = fvs `plusFV` mkFVs extra_deps
905                                | otherwise
906                                = fvs
907
908              ds_w_fvs' = mapSnd add_boot_deps ds_w_fvs
909
910              sccs :: [SCC (LTyClDecl Name)]
911              sccs = depAnalTyClDecls ds_w_fvs'
912
913              all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs'
914
915              raw_groups = map flattenSCC sccs
916              -- See Note [Role annotations in the renamer]
917              (groups, orphan_roles)
918                = foldr (\group (groups_acc, orphans_acc) ->
919                          let names = map (tcdName . unLoc) group
920                              roles = mapMaybe (lookupNameEnv orphans_acc) names
921                              orphans' = delListFromNameEnv orphans_acc names
922                               -- there doesn't seem to be an interface to
923                               -- do the above more efficiently
924                          in ( TyClGroup { group_tyclds = group
925                                         , group_roles  = roles } : groups_acc
926                             , orphans' )
927                        )
928                        ([], role_annot_env)
929                        raw_groups
930                  
931        ; mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles)
932        ; traceRn (text "rnTycl"  <+> (ppr ds_w_fvs $$ ppr sccs))
933        ; return (groups, all_fvs) }
934
935 rnTyClDecl :: TyClDecl RdrName 
936            -> RnM (TyClDecl Name, FreeVars)
937 rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name})
938   = do { name' <- lookupLocatedTopBndrRn name
939        ; return (ForeignType {tcdLName = name', tcdExtName = ext_name},
940                  emptyFVs) }
941
942 -- All flavours of type family declarations ("type family", "newtype family",
943 -- and "data family"), both top level and (for an associated type)
944 -- in a class decl
945 rnTyClDecl (FamDecl { tcdFam = decl })
946   = do { (decl', fvs) <- rnFamDecl Nothing decl
947        ; return (FamDecl decl', fvs) }
948
949 rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs })
950   = do { tycon' <- lookupLocatedTopBndrRn tycon
951        ; let kvs = fst (extractHsTyRdrTyVars rhs)
952              doc = TySynCtx tycon
953        ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs)
954        ; ((tyvars', rhs'), fvs) <- bindHsTyVars doc Nothing kvs tyvars $
955                                     \ tyvars' ->
956                                     do { (rhs', fvs) <- rnTySyn doc rhs
957                                        ; return ((tyvars', rhs'), fvs) }
958        ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
959                          , tcdRhs = rhs', tcdFVs = fvs }, fvs) }
960
961 -- "data", "newtype" declarations
962 -- both top level and (for an associated type) in an instance decl
963 rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn })
964   = do { tycon' <- lookupLocatedTopBndrRn tycon
965        ; let kvs = extractDataDefnKindVars defn
966              doc = TyDataCtx tycon
967        ; traceRn (text "rntycl-data" <+> ppr tycon <+> ppr kvs)
968        ; ((tyvars', defn'), fvs) <- bindHsTyVars doc Nothing kvs tyvars $ \ tyvars' ->
969                                     do { (defn', fvs) <- rnDataDefn doc defn
970                                        ; return ((tyvars', defn'), fvs) }
971        ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
972                           , tcdDataDefn = defn', tcdFVs = fvs }, fvs) }
973
974 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls, 
975                               tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
976                               tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
977                               tcdDocs = docs})
978   = do  { lcls' <- lookupLocatedTopBndrRn lcls
979         ; let cls' = unLoc lcls'
980               kvs = []  -- No scoped kind vars except those in
981                         -- kind signatures on the tyvars
982
983         -- Tyvars scope over superclass context and method signatures
984         ; ((tyvars', context', fds', ats', sigs'), stuff_fvs)
985             <- bindHsTyVars cls_doc Nothing kvs tyvars $ \ tyvars' -> do
986                   -- Checks for distinct tyvars
987              { (context', cxt_fvs) <- rnContext cls_doc context
988              ; fds'  <- rnFds fds
989                          -- The fundeps have no free variables
990              ; (ats',     fv_ats)     <- rnATDecls cls' ats
991              ; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs
992              ; let fvs = cxt_fvs     `plusFV`
993                          sig_fvs     `plusFV`
994                          fv_ats
995              ; return ((tyvars', context', fds', ats', sigs'), fvs) }
996
997         ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltEqn cls') at_defs
998
999         -- No need to check for duplicate associated type decls
1000         -- since that is done by RnNames.extendGlobalRdrEnvRn
1001
1002         -- Check the signatures
1003         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
1004         ; let sig_rdr_names_w_locs = [op | L _ (TypeSig ops _) <- sigs, op <- ops]
1005         ; checkDupRdrNames sig_rdr_names_w_locs
1006                 -- Typechecker is responsible for checking that we only
1007                 -- give default-method bindings for things in this class.
1008                 -- The renamer *could* check this for class decls, but can't
1009                 -- for instance decls.
1010
1011         -- The newLocals call is tiresome: given a generic class decl
1012         --      class C a where
1013         --        op :: a -> a
1014         --        op {| x+y |} (Inl a) = ...
1015         --        op {| x+y |} (Inr b) = ...
1016         --        op {| a*b |} (a*b)   = ...
1017         -- we want to name both "x" tyvars with the same unique, so that they are
1018         -- easy to group together in the typechecker.
1019         ; (mbinds', meth_fvs)
1020             <- extendTyVarEnvForMethodBinds (hsLKiTyVarNames tyvars') $
1021                 -- No need to check for duplicate method signatures
1022                 -- since that is done by RnNames.extendGlobalRdrEnvRn
1023                 -- and the methods are already in scope
1024                  rnMethodBinds cls' (mkSigTvFn sigs') mbinds
1025
1026   -- Haddock docs
1027         ; docs' <- mapM (wrapLocM rnDocDecl) docs
1028
1029         ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs
1030         ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',
1031                               tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
1032                               tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
1033                               tcdDocs = docs', tcdFVs = all_fvs },
1034                   all_fvs ) }
1035   where
1036     cls_doc  = ClassDeclCtx lcls
1037
1038 -- "type" and "type instance" declarations
1039 rnTySyn :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
1040 rnTySyn doc rhs = rnLHsType doc rhs
1041
1042 -- Renames role annotations, returning them as the values in a NameEnv
1043 -- and checks for duplicate role annotations.
1044 -- It is quite convenient to do both of these in the same place.
1045 -- See also Note [Role annotations in the renamer]
1046 rnRoleAnnots :: [LRoleAnnotDecl RdrName]
1047                 -> RnM (NameEnv (LRoleAnnotDecl Name))
1048 rnRoleAnnots role_annots
1049   = do {  -- check for duplicates *before* renaming, to avoid lumping
1050           -- together all the unboundNames
1051          let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots
1052              role_annots_cmp (L _ annot1) (L _ annot2)
1053                = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2
1054        ; mapM_ dupRoleAnnotErr dup_annots
1055        ; role_annots' <- mapM (wrapLocM rn_role_annot1) no_dups
1056           -- some of the role annots will be unbound; we don't wish
1057           -- to include these
1058        ; return $ mkNameEnv [ (name, ra)
1059                             | ra <- role_annots'
1060                             , let name = roleAnnotDeclName (unLoc ra)
1061                             , not (isUnboundName name) ] }
1062   where
1063     rn_role_annot1 (RoleAnnotDecl tycon roles)
1064       = do {  -- the name is an *occurrence*
1065              tycon' <- wrapLocM lookupGlobalOccRn tycon
1066            ; return $ RoleAnnotDecl tycon' roles }
1067
1068 dupRoleAnnotErr :: [LRoleAnnotDecl RdrName] -> RnM ()
1069 dupRoleAnnotErr [] = panic "dupRoleAnnotErr"
1070 dupRoleAnnotErr list
1071   = addErrAt loc $
1072     hang (text "Duplicate role annotations for" <+>
1073           quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
1074        2 (vcat $ map pp_role_annot sorted_list)
1075     where
1076       sorted_list = sortBy cmp_annot list
1077       (L loc first_decl : _) = sorted_list
1078     
1079       pp_role_annot (L loc decl) = hang (ppr decl)
1080                                       4 (text "-- written at" <+> ppr loc)
1081
1082       cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2
1083
1084 orphanRoleAnnotErr :: LRoleAnnotDecl Name -> RnM ()
1085 orphanRoleAnnotErr (L loc decl)
1086   = addErrAt loc $
1087     hang (text "Role annotation for a type previously declared:")
1088        2 (ppr decl) $$
1089     parens (text "The role annotation must be given where" <+>
1090             quotes (ppr $ roleAnnotDeclName decl) <+>
1091             text "is declared.")
1092
1093 rnDataDefn :: HsDocContext -> HsDataDefn RdrName -> RnM (HsDataDefn Name, FreeVars)
1094 rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1095                            , dd_ctxt = context, dd_cons = condecls 
1096                            , dd_kindSig = sig, dd_derivs = derivs })
1097   = do  { checkTc (h98_style || null (unLoc context)) 
1098                   (badGadtStupidTheta doc)
1099
1100         ; (sig', sig_fvs)  <- rnLHsMaybeKind doc sig
1101         ; (context', fvs1) <- rnContext doc context
1102         ; (derivs',  fvs3) <- rn_derivs derivs
1103
1104         -- For the constructor declarations, drop the LocalRdrEnv
1105         -- in the GADT case, where the type variables in the declaration
1106         -- do not scope over the constructor signatures
1107         -- data T a where { T1 :: forall b. b-> b }
1108         ; let { zap_lcl_env | h98_style = \ thing -> thing
1109                             | otherwise = setLocalRdrEnv emptyLocalRdrEnv }
1110         ; (condecls', con_fvs) <- zap_lcl_env $
1111                                   rnConDecls condecls
1112            -- No need to check for duplicate constructor decls
1113            -- since that is done by RnNames.extendGlobalRdrEnvRn
1114
1115         ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
1116                         con_fvs `plusFV` sig_fvs
1117         ; return ( HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1118                               , dd_ctxt = context', dd_kindSig = sig'
1119                               , dd_cons = condecls', dd_derivs = derivs' }
1120                  , all_fvs )
1121         }
1122   where
1123     h98_style = case condecls of         -- Note [Stupid theta]
1124                      L _ (ConDecl { con_res = ResTyGADT {} }) : _  -> False
1125                      _                                             -> True
1126
1127     rn_derivs Nothing   = return (Nothing, emptyFVs)
1128     rn_derivs (Just ds) = do { (ds', fvs) <- rnLHsTypes doc ds
1129                              ; return (Just ds', fvs) }
1130
1131 badGadtStupidTheta :: HsDocContext -> SDoc
1132 badGadtStupidTheta _
1133   = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
1134           ptext (sLit "(You can put a context on each contructor, though.)")]
1135
1136 rnFamDecl :: Maybe Name
1137                     -- Just cls => this FamilyDecl is nested 
1138                     --             inside an *class decl* for cls
1139                     --             used for associated types
1140           -> FamilyDecl RdrName
1141           -> RnM (FamilyDecl Name, FreeVars)
1142 rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
1143                              , fdInfo = info, fdKindSig = kind })
1144   = do { ((tycon', tyvars', kind'), fv1) <-
1145            bindHsTyVars fmly_doc mb_cls kvs tyvars $ \tyvars' ->
1146            do { tycon' <- lookupLocatedTopBndrRn tycon
1147               ; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind
1148               ; return ((tycon', tyvars', kind'), fv_kind) }
1149        ; (info', fv2) <- rn_info info
1150        ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars'
1151                             , fdInfo = info', fdKindSig = kind' }
1152                 , fv1 `plusFV` fv2) }
1153   where 
1154      fmly_doc = TyFamilyCtx tycon
1155      kvs = extractRdrKindSigVars kind
1156
1157      rn_info (ClosedTypeFamily eqns)
1158        = do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns
1159                                                     -- no class context,
1160             ; return (ClosedTypeFamily eqns', fvs) }
1161      rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
1162      rn_info DataFamily     = return (DataFamily, emptyFVs)
1163      
1164 \end{code}
1165
1166 Note [Stupid theta]
1167 ~~~~~~~~~~~~~~~~~~~
1168 Trac #3850 complains about a regression wrt 6.10 for
1169      data Show a => T a
1170 There is no reason not to allow the stupid theta if there are no data
1171 constructors.  It's still stupid, but does no harm, and I don't want
1172 to cause programs to break unnecessarily (notably HList).  So if there
1173 are no data constructors we allow h98_style = True
1174
1175
1176 \begin{code}
1177 depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)]
1178 -- See Note [Dependency analysis of type and class decls]
1179 depAnalTyClDecls ds_w_fvs
1180   = stronglyConnCompFromEdgedVertices edges
1181   where
1182     edges = [ (d, tcdName (unLoc d), map get_parent (nameSetToList fvs))
1183             | (d, fvs) <- ds_w_fvs ]
1184
1185     -- We also need to consider data constructor names since
1186     -- they may appear in types because of promotion.
1187     get_parent n = lookupNameEnv assoc_env n `orElse` n
1188
1189     assoc_env :: NameEnv Name   -- Maps a data constructor back
1190                                 -- to its parent type constructor
1191     assoc_env = mkNameEnv assoc_env_list
1192     assoc_env_list = do
1193       (L _ d, _) <- ds_w_fvs
1194       case d of
1195         ClassDecl { tcdLName = L _ cls_name
1196                   , tcdATs = ats } 
1197           -> do L _ (FamilyDecl { fdLName = L _ fam_name }) <- ats
1198                 return (fam_name, cls_name)
1199         DataDecl { tcdLName = L _ data_name
1200                  , tcdDataDefn = HsDataDefn { dd_cons = cons } } 
1201           -> do L _ dc <- cons
1202                 return (unLoc (con_name dc), data_name)
1203         _ -> []
1204 \end{code}
1205
1206 Note [Dependency analysis of type and class decls]
1207 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1208 We need to do dependency analysis on type and class declarations
1209 else we get bad error messages.  Consider
1210
1211      data T f a = MkT f a
1212      data S f a = MkS f (T f a)
1213
1214 This has a kind error, but the error message is better if you
1215 check T first, (fixing its kind) and *then* S.  If you do kind
1216 inference together, you might get an error reported in S, which
1217 is jolly confusing.  See Trac #4875
1218
1219 Note [Role annotations in the renamer]
1220 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1221 We must ensure that a type's role annotation is put in the same group as the
1222 proper type declaration. This is because role annotations are needed during
1223 type-checking when creating the type's TyCon. So, rnRoleAnnots builds a
1224 NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that
1225 type, if any. Then, this map can be used to add the role annotations to the
1226 groups after dependency analysis.
1227
1228 This process checks for duplicate role annotations, where we must be careful
1229 to do the check *before* renaming to avoid calling all unbound names duplicates
1230 of one another.
1231
1232 The renaming process, as usual, might identify and report errors for unbound
1233 names. We exclude the annotations for unbound names in the annotation
1234 environment to avoid spurious errors for orphaned annotations.
1235
1236 We then (in rnTyClDecls) do a check for orphan role annotations (role
1237 annotations without an accompanying type decl). The check works by folding
1238 over raw_groups (of type [[TyClDecl Name]]), selecting out the relevant
1239 role declarations for each group, as well as diminishing the annotation
1240 environment. After the fold is complete, anything left over in the name
1241 environment must be an orphan, and errors are generated.
1242
1243 An earlier version of this algorithm short-cut the orphan check by renaming
1244 only with names declared in this module. But, this check is insufficient in
1245 the case of staged module compilation (Template Haskell, GHCi).
1246 See #8485. With the new lookup process (which includes types declared in other
1247 modules), we get better error messages, too.
1248
1249 %*********************************************************
1250 %*                                                      *
1251 \subsection{Support code for type/data declarations}
1252 %*                                                      *
1253 %*********************************************************
1254
1255 \begin{code}
1256 ---------------
1257 badAssocRhs :: [Name] -> RnM ()
1258 badAssocRhs ns
1259   = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable")
1260                   <> plural ns
1261                   <+> pprWithCommas (quotes . ppr) ns)
1262                2 (ptext (sLit "All such variables must be bound on the LHS")))
1263
1264 -----------------
1265 rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
1266 rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
1267
1268 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars)
1269 rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
1270                         , con_cxt = lcxt@(L loc cxt), con_details = details
1271                         , con_res = res_ty, con_doc = mb_doc
1272                         , con_old_rec = old_rec, con_explicit = expl })
1273   = do  { addLocM checkConName name
1274         ; when old_rec (addWarn (deprecRecSyntax decl))
1275         ; new_name <- lookupLocatedTopBndrRn name
1276
1277            -- For H98 syntax, the tvs are the existential ones
1278            -- For GADT syntax, the tvs are all the quantified tyvars
1279            -- Hence the 'filter' in the ResTyH98 case only
1280         ; rdr_env <- getLocalRdrEnv
1281         ; let arg_tys    = hsConDeclArgTys details
1282               (free_kvs, free_tvs) = case res_ty of
1283                                      ResTyH98 -> filterInScope rdr_env (get_rdr_tvs arg_tys)
1284                                      ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
1285
1286          -- With an Explicit forall, check for unused binders
1287          -- With Implicit, find the mentioned ones, and use them as binders
1288         ; new_tvs <- case expl of
1289                        Implicit -> return (mkHsQTvs (userHsTyVarBndrs loc free_tvs))
1290                        Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs free_tvs
1291                                       ; return tvs }
1292
1293         ; mb_doc' <- rnMbLHsDoc mb_doc
1294
1295         ; bindHsTyVars doc Nothing free_kvs new_tvs $ \new_tyvars -> do
1296         { (new_context, fvs1) <- rnContext doc lcxt
1297         ; (new_details, fvs2) <- rnConDeclDetails doc details
1298         ; (new_details', new_res_ty, fvs3) <- rnConResult doc (unLoc new_name) new_details res_ty
1299         ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context
1300                        , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' },
1301                   fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
1302  where
1303     doc = ConDeclCtx name
1304     get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys)
1305
1306 rnConResult :: HsDocContext -> Name
1307             -> HsConDetails (LHsType Name) [ConDeclField Name]
1308             -> ResType (LHsType RdrName)
1309             -> RnM (HsConDetails (LHsType Name) [ConDeclField Name],
1310                     ResType (LHsType Name), FreeVars)
1311 rnConResult _   _   details ResTyH98 = return (details, ResTyH98, emptyFVs)
1312 rnConResult doc con details (ResTyGADT ty)
1313   = do { (ty', fvs) <- rnLHsType doc ty
1314        ; let (arg_tys, res_ty) = splitHsFunType ty'
1315                 -- We can finally split it up,
1316                 -- now the renamer has dealt with fixities
1317                 -- See Note [Sorting out the result type] in RdrHsSyn
1318
1319        ; case details of
1320            InfixCon {}  -> pprPanic "rnConResult" (ppr ty)
1321            -- See Note [Sorting out the result type] in RdrHsSyn
1322
1323            RecCon {}    -> do { unless (null arg_tys)
1324                                        (addErr (badRecResTy (docOfHsDocContext doc)))
1325                               ; return (details, ResTyGADT res_ty, fvs) }
1326
1327            PrefixCon {} | isSymOcc (getOccName con)  -- See Note [Infix GADT cons]
1328                         , [ty1,ty2] <- arg_tys
1329                         -> do { fix_env <- getFixityEnv
1330                               ; return (if   con `elemNameEnv` fix_env
1331                                         then InfixCon ty1 ty2
1332                                         else PrefixCon arg_tys
1333                                        , ResTyGADT res_ty, fvs) }
1334                         | otherwise
1335                         -> return (PrefixCon arg_tys, ResTyGADT res_ty, fvs) }
1336
1337 rnConDeclDetails :: HsDocContext
1338                  -> HsConDetails (LHsType RdrName) [ConDeclField RdrName]
1339                  -> RnM (HsConDetails (LHsType Name) [ConDeclField Name], FreeVars)
1340 rnConDeclDetails doc (PrefixCon tys)
1341   = do { (new_tys, fvs) <- rnLHsTypes doc tys
1342        ; return (PrefixCon new_tys, fvs) }
1343
1344 rnConDeclDetails doc (InfixCon ty1 ty2)
1345   = do { (new_ty1, fvs1) <- rnLHsType doc ty1
1346        ; (new_ty2, fvs2) <- rnLHsType doc ty2
1347        ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
1348
1349 rnConDeclDetails doc (RecCon fields)
1350   = do  { (new_fields, fvs) <- rnConDeclFields doc fields
1351                 -- No need to check for duplicate fields
1352                 -- since that is done by RnNames.extendGlobalRdrEnvRn
1353         ; return (RecCon new_fields, fvs) }
1354
1355 -------------------------------------------------
1356 deprecRecSyntax :: ConDecl RdrName -> SDoc
1357 deprecRecSyntax decl
1358   = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_name decl))
1359                  <+> ptext (sLit "uses deprecated syntax")
1360          , ptext (sLit "Instead, use the form")
1361          , nest 2 (ppr decl) ]   -- Pretty printer uses new form
1362
1363 badRecResTy :: SDoc -> SDoc
1364 badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
1365 \end{code}
1366
1367 Note [Infix GADT constructors]
1368 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1369 We do not currently have syntax to declare an infix constructor in GADT syntax,
1370 but it makes a (small) difference to the Show instance.  So as a slightly
1371 ad-hoc solution, we regard a GADT data constructor as infix if
1372   a) it is an operator symbol
1373   b) it has two arguments
1374   c) there is a fixity declaration for it
1375 For example:
1376    infix 6 (:--:)
1377    data T a where
1378      (:--:) :: t1 -> t2 -> T Int
1379
1380 %*********************************************************
1381 %*                                                      *
1382 \subsection{Support code for type/data declarations}
1383 %*                                                      *
1384 %*********************************************************
1385
1386 Get the mapping from constructors to fields for this module.
1387 It's convenient to do this after the data type decls have been renamed
1388 \begin{code}
1389 extendRecordFieldEnv :: [TyClGroup RdrName] -> [LInstDecl RdrName] -> TcM TcGblEnv
1390 extendRecordFieldEnv tycl_decls inst_decls
1391   = do  { tcg_env <- getGblEnv
1392         ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
1393         ; return (tcg_env { tcg_field_env = field_env' }) }
1394   where
1395     -- we want to lookup:
1396     --  (a) a datatype constructor
1397     --  (b) a record field
1398     -- knowing that they're from this module.
1399     -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn_maybe,
1400     -- which keeps only the local ones.
1401     lookup x = do { x' <- lookupLocatedTopBndrRn x
1402                     ; return $ unLoc x'}
1403
1404     all_data_cons :: [ConDecl RdrName]
1405     all_data_cons = [con | HsDataDefn { dd_cons = cons } <- all_ty_defs
1406                          , L _ con <- cons ]
1407     all_ty_defs = [ defn | L _ (DataDecl { tcdDataDefn = defn }) <- tyClGroupConcat tycl_decls ]
1408                ++ map dfid_defn (instDeclDataFamInsts inst_decls)  -- Do not forget associated types!
1409
1410     get_con (ConDecl { con_name = con, con_details = RecCon flds })
1411             (RecFields env fld_set)
1412         = do { con' <- lookup con
1413              ; flds' <- mapM lookup (map cd_fld_name flds)
1414              ; let env'    = extendNameEnv env con' flds'
1415                    fld_set' = addListToNameSet fld_set flds'
1416              ; return $ (RecFields env' fld_set') }
1417     get_con _ env = return env
1418 \end{code}
1419
1420 %*********************************************************
1421 %*                                                      *
1422 \subsection{Support code to rename types}
1423 %*                                                      *
1424 %*********************************************************
1425
1426 \begin{code}
1427 rnFds :: [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
1428 rnFds fds
1429   = mapM (wrapLocM rn_fds) fds
1430   where
1431     rn_fds (tys1, tys2)
1432       = do { tys1' <- rnHsTyVars tys1
1433            ; tys2' <- rnHsTyVars tys2
1434            ; return (tys1', tys2') }
1435
1436 rnHsTyVars :: [RdrName] -> RnM [Name]
1437 rnHsTyVars tvs  = mapM rnHsTyVar tvs
1438
1439 rnHsTyVar :: RdrName -> RnM Name
1440 rnHsTyVar tyvar = lookupOccRn tyvar
1441 \end{code}
1442
1443
1444 %*********************************************************
1445 %*                                                      *
1446         findSplice
1447 %*                                                      *
1448 %*********************************************************
1449
1450 This code marches down the declarations, looking for the first
1451 Template Haskell splice.  As it does so it
1452         a) groups the declarations into a HsGroup
1453         b) runs any top-level quasi-quotes
1454
1455 \begin{code}
1456 findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1457 findSplice ds = addl emptyRdrGroup ds
1458
1459 addl :: HsGroup RdrName -> [LHsDecl RdrName]
1460      -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1461 -- This stuff reverses the declarations (again) but it doesn't matter
1462 addl gp []           = return (gp, Nothing)
1463 addl gp (L l d : ds) = add gp l d ds
1464
1465
1466 add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName]
1467     -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1468
1469 add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
1470   = do { -- We've found a top-level splice.  If it is an *implicit* one
1471          -- (i.e. a naked top level expression)
1472          case flag of
1473            Explicit -> return ()
1474            Implicit -> do { th_on <- xoptM Opt_TemplateHaskell
1475                           ; unless th_on $ setSrcSpan loc $
1476                             failWith badImplicitSplice }
1477
1478        ; return (gp, Just (splice, ds)) }
1479   where
1480     badImplicitSplice = ptext (sLit "Parse error: naked expression at top level")
1481                      $$ ptext (sLit "Perhaps you intended to use TemplateHaskell")
1482
1483 add gp _ (QuasiQuoteD qq) ds            -- Expand quasiquotes
1484   = do { ds' <- runQuasiQuoteDecl qq
1485        ; addl gp (ds' ++ ds) }
1486
1487 -- Class declarations: pull out the fixity signatures to the top
1488 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
1489   | isClassDecl d
1490   = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
1491     addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
1492   | otherwise
1493   = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
1494
1495 -- Signatures: fixity sigs go a different place than all others
1496 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
1497   = addl (gp {hs_fixds = L l f : ts}) ds
1498 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
1499   = addl (gp {hs_valds = add_sig (L l d) ts}) ds
1500
1501 -- Value declarations: use add_bind
1502 add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
1503   = addl (gp { hs_valds = add_bind (L l d) ts }) ds
1504
1505 -- Role annotations: added to the TyClGroup
1506 add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD d) ds
1507   = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds
1508
1509 -- The rest are routine
1510 add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
1511   = addl (gp { hs_instds = L l d : ts }) ds
1512 add gp@(HsGroup {hs_derivds = ts})  l (DerivD d) ds
1513   = addl (gp { hs_derivds = L l d : ts }) ds
1514 add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
1515   = addl (gp { hs_defds = L l d : ts }) ds
1516 add gp@(HsGroup {hs_fords  = ts}) l (ForD d) ds
1517   = addl (gp { hs_fords = L l d : ts }) ds
1518 add gp@(HsGroup {hs_warnds  = ts})  l (WarningD d) ds
1519   = addl (gp { hs_warnds = L l d : ts }) ds
1520 add gp@(HsGroup {hs_annds  = ts}) l (AnnD d) ds
1521   = addl (gp { hs_annds = L l d : ts }) ds
1522 add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
1523   = addl (gp { hs_ruleds = L l d : ts }) ds
1524 add gp@(HsGroup {hs_vects  = ts}) l (VectD d) ds
1525   = addl (gp { hs_vects = L l d : ts }) ds
1526 add gp l (DocD d) ds
1527   = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds
1528
1529 add_tycld :: LTyClDecl a -> [TyClGroup a] -> [TyClGroup a]
1530 add_tycld d []       = [TyClGroup { group_tyclds = [d], group_roles = [] }]
1531 add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
1532   = ds { group_tyclds = d : tyclds } : dss
1533
1534 add_role_annot :: LRoleAnnotDecl a -> [TyClGroup a] -> [TyClGroup a]
1535 add_role_annot d [] = [TyClGroup { group_tyclds = [], group_roles = [d] }]
1536 add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
1537   = tycls { group_roles = d : roles } : rest
1538
1539 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
1540 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
1541 add_bind _ (ValBindsOut {})     = panic "RdrHsSyn:add_bind"
1542
1543 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
1544 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
1545 add_sig _ (ValBindsOut {})     = panic "RdrHsSyn:add_sig"
1546 \end{code}