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