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