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