ApiAnnotations : strings in warnings do not return SourceText
[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 src label Nothing isFun
435 -> StaticTarget src label (Just packageKey) isFun
436 _ -> callTarget
437
438 {-
439 *********************************************************
440 * *
441 \subsection{Instance declarations}
442 * *
443 *********************************************************
444 -}
445
446 rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
447 rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })
448 = do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi
449 ; return (TyFamInstD { tfid_inst = tfi' }, fvs) }
450
451 rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })
452 = do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi
453 ; return (DataFamInstD { dfid_inst = dfi' }, fvs) }
454
455 rnSrcInstDecl (ClsInstD { cid_inst = cid })
456 = do { (cid', fvs) <- rnClsInstDecl cid
457 ; return (ClsInstD { cid_inst = cid' }, fvs) }
458
459 rnClsInstDecl :: ClsInstDecl RdrName -> RnM (ClsInstDecl Name, FreeVars)
460 rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
461 , cid_sigs = uprags, cid_tyfam_insts = ats
462 , cid_overlap_mode = oflag
463 , cid_datafam_insts = adts })
464 -- Used for both source and interface file decls
465 = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty
466 ; case splitLHsInstDeclTy_maybe inst_ty' of {
467 Nothing -> return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds
468 , cid_sigs = [], cid_tyfam_insts = []
469 , cid_overlap_mode = oflag
470 , cid_datafam_insts = [] }
471 , inst_fvs) ;
472 Just (inst_tyvars, _, L _ cls,_) ->
473
474 do { let (spec_inst_prags, other_sigs) = partition isSpecInstLSig uprags
475 ktv_names = hsLKiTyVarNames inst_tyvars
476
477 -- Rename the associated types, and type signatures
478 -- Both need to have the instance type variables in scope
479 ; traceRn (text "rnSrcInstDecl" <+> ppr inst_ty' $$ ppr inst_tyvars $$ ppr ktv_names)
480 ; ((ats', adts', other_sigs'), more_fvs)
481 <- extendTyVarEnvFVRn ktv_names $
482 do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls inst_tyvars ats
483 ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls inst_tyvars adts
484 ; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs
485 ; return ( (ats', adts', other_sigs')
486 , at_fvs `plusFV` adt_fvs `plusFV` sig_fvs) }
487
488 -- Rename the bindings
489 -- The typechecker (not the renamer) checks that all
490 -- the bindings are for the right class
491 -- (Slightly strangely) when scoped type variables are on, the
492 -- forall-d tyvars scope over the method bindings too
493 ; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds ktv_names $
494 rnMethodBinds cls (mkSigTvFn other_sigs')
495 mbinds
496
497 -- Rename the SPECIALISE instance pramas
498 -- Annoyingly the type variables are not in scope here,
499 -- so that instance Eq a => Eq (T a) where
500 -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
501 -- works OK. That's why we did the partition game above
502 --
503 ; (spec_inst_prags', spec_inst_fvs)
504 <- renameSigs (InstDeclCtxt cls) spec_inst_prags
505
506 ; let uprags' = spec_inst_prags' ++ other_sigs'
507 all_fvs = meth_fvs `plusFV` more_fvs
508 `plusFV` spec_inst_fvs
509 `plusFV` inst_fvs
510 ; return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = mbinds'
511 , cid_sigs = uprags', cid_tyfam_insts = ats'
512 , cid_overlap_mode = oflag
513 , cid_datafam_insts = adts' },
514 all_fvs) } } }
515 -- We return the renamed associated data type declarations so
516 -- that they can be entered into the list of type declarations
517 -- for the binding group, but we also keep a copy in the instance.
518 -- The latter is needed for well-formedness checks in the type
519 -- checker (eg, to ensure that all ATs of the instance actually
520 -- receive a declaration).
521 -- NB: Even the copies in the instance declaration carry copies of
522 -- the instance context after renaming. This is a bit
523 -- strange, but should not matter (and it would be more work
524 -- to remove the context).
525
526 rnFamInstDecl :: HsDocContext
527 -> Maybe (Name, [Name])
528 -> Located RdrName
529 -> [LHsType RdrName]
530 -> rhs
531 -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
532 -> RnM (Located Name, HsWithBndrs Name [LHsType Name], rhs',
533 FreeVars)
534 rnFamInstDecl doc mb_cls tycon pats payload rnPayload
535 = do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon
536 ; let loc = case pats of
537 [] -> pprPanic "rnFamInstDecl" (ppr tycon)
538 (L loc _ : []) -> loc
539 (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
540 (kv_rdr_names, tv_rdr_names) = extractHsTysRdrTyVars pats
541
542
543 ; rdr_env <- getLocalRdrEnv
544 ; kv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) kv_rdr_names
545 ; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names
546 -- All the free vars of the family patterns
547 -- with a sensible binding location
548 ; ((pats', payload'), fvs)
549 <- bindLocalNamesFV kv_names $
550 bindLocalNamesFV tv_names $
551 do { (pats', pat_fvs) <- rnLHsTypes doc pats
552 ; (payload', rhs_fvs) <- rnPayload doc payload
553
554 -- See Note [Renaming associated types]
555 ; let lhs_names = mkNameSet kv_names `unionNameSet` mkNameSet tv_names
556 bad_tvs = case mb_cls of
557 Nothing -> []
558 Just (_,cls_tkvs) -> filter is_bad cls_tkvs
559
560 is_bad cls_tkv = cls_tkv `elemNameSet` rhs_fvs
561 && not (cls_tkv `elemNameSet` lhs_names)
562
563 ; unless (null bad_tvs) (badAssocRhs bad_tvs)
564 ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) }
565
566
567 ; let all_fvs = fvs `addOneFV` unLoc tycon'
568 ; return (tycon',
569 HsWB { hswb_cts = pats', hswb_kvs = kv_names,
570 hswb_tvs = tv_names, hswb_wcs = [] },
571 payload',
572 all_fvs) }
573 -- type instance => use, hence addOneFV
574
575 rnTyFamInstDecl :: Maybe (Name, [Name])
576 -> TyFamInstDecl RdrName
577 -> RnM (TyFamInstDecl Name, FreeVars)
578 rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = L loc eqn })
579 = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn
580 ; return (TyFamInstDecl { tfid_eqn = L loc eqn'
581 , tfid_fvs = fvs }, fvs) }
582
583 rnTyFamInstEqn :: Maybe (Name, [Name])
584 -> TyFamInstEqn RdrName
585 -> RnM (TyFamInstEqn Name, FreeVars)
586 rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon
587 , tfe_pats = HsWB { hswb_cts = pats }
588 , tfe_rhs = rhs })
589 = do { (tycon', pats', rhs', fvs) <-
590 rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn
591 ; return (TyFamEqn { tfe_tycon = tycon'
592 , tfe_pats = pats'
593 , tfe_rhs = rhs' }, fvs) }
594
595 rnTyFamDefltEqn :: Name
596 -> TyFamDefltEqn RdrName
597 -> RnM (TyFamDefltEqn Name, FreeVars)
598 rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon
599 , tfe_pats = tyvars
600 , tfe_rhs = rhs })
601 = bindHsTyVars ctx (Just cls) [] tyvars $ \ tyvars' ->
602 do { tycon' <- lookupFamInstName (Just cls) tycon
603 ; (rhs', fvs) <- rnLHsType ctx rhs
604 ; return (TyFamEqn { tfe_tycon = tycon'
605 , tfe_pats = tyvars'
606 , tfe_rhs = rhs' }, fvs) }
607 where
608 ctx = TyFamilyCtx tycon
609
610 rnDataFamInstDecl :: Maybe (Name, [Name])
611 -> DataFamInstDecl RdrName
612 -> RnM (DataFamInstDecl Name, FreeVars)
613 rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon
614 , dfid_pats = HsWB { hswb_cts = pats }
615 , dfid_defn = defn })
616 = do { (tycon', pats', defn', fvs) <-
617 rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn
618 ; return (DataFamInstDecl { dfid_tycon = tycon'
619 , dfid_pats = pats'
620 , dfid_defn = defn'
621 , dfid_fvs = fvs }, fvs) }
622
623 -- Renaming of the associated types in instances.
624
625 -- Rename associated type family decl in class
626 rnATDecls :: Name -- Class
627 -> [LFamilyDecl RdrName]
628 -> RnM ([LFamilyDecl Name], FreeVars)
629 rnATDecls cls at_decls
630 = rnList (rnFamDecl (Just cls)) at_decls
631
632 rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames
633 decl RdrName -> -- an instance. rnTyFamInstDecl
634 RnM (decl Name, FreeVars)) -- or rnDataFamInstDecl
635 -> Name -- Class
636 -> LHsTyVarBndrs Name
637 -> [Located (decl RdrName)]
638 -> RnM ([Located (decl Name)], FreeVars)
639 -- Used for data and type family defaults in a class decl
640 -- and the family instance declarations in an instance
641 --
642 -- NB: We allow duplicate associated-type decls;
643 -- See Note [Associated type instances] in TcInstDcls
644 rnATInstDecls rnFun cls hs_tvs at_insts
645 = rnList (rnFun (Just (cls, tv_ns))) at_insts
646 where
647 tv_ns = hsLKiTyVarNames hs_tvs
648 -- See Note [Renaming associated types]
649
650 {-
651 Note [Renaming associated types]
652 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
653 Check that the RHS of the decl mentions only type variables
654 bound on the LHS. For example, this is not ok
655 class C a b where
656 type F a x :: *
657 instance C (p,q) r where
658 type F (p,q) x = (x, r) -- BAD: mentions 'r'
659 c.f. Trac #5515
660
661 The same thing applies to kind variables, of course (Trac #7938, #9574):
662 class Funct f where
663 type Codomain f :: *
664 instance Funct ('KProxy :: KProxy o) where
665 type Codomain 'KProxy = NatTr (Proxy :: o -> *)
666 Here 'o' is mentioned on the RHS of the Codomain function, but
667 not on the LHS.
668
669 All this applies only for *instance* declarations. In *class*
670 declarations there is no RHS to worry about, and the class variables
671 can all be in scope (Trac #5862):
672 class Category (x :: k -> k -> *) where
673 type Ob x :: k -> Constraint
674 id :: Ob x a => x a a
675 (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c
676 Here 'k' is in scope in the kind signature, just like 'x'.
677 -}
678
679 extendTyVarEnvForMethodBinds :: [Name]
680 -> RnM (LHsBinds Name, FreeVars)
681 -> RnM (LHsBinds Name, FreeVars)
682 -- For the method bindings in class and instance decls, we extend
683 -- the type variable environment iff -XScopedTypeVariables
684
685 extendTyVarEnvForMethodBinds ktv_names thing_inside
686 = do { scoped_tvs <- xoptM Opt_ScopedTypeVariables
687 ; if scoped_tvs then
688 extendTyVarEnvFVRn ktv_names thing_inside
689 else
690 thing_inside }
691
692 {-
693 *********************************************************
694 * *
695 \subsection{Stand-alone deriving declarations}
696 * *
697 *********************************************************
698 -}
699
700 rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
701 rnSrcDerivDecl (DerivDecl ty overlap)
702 = do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving
703 ; unless standalone_deriv_ok (addErr standaloneDerivErr)
704 ; (ty', fvs) <- rnLHsInstType (text "In a deriving declaration") ty
705 ; return (DerivDecl ty' overlap, fvs) }
706
707 standaloneDerivErr :: SDoc
708 standaloneDerivErr
709 = hang (ptext (sLit "Illegal standalone deriving declaration"))
710 2 (ptext (sLit "Use StandaloneDeriving to enable this extension"))
711
712 {-
713 *********************************************************
714 * *
715 \subsection{Rules}
716 * *
717 *********************************************************
718 -}
719
720 rnHsRuleDecls :: RuleDecls RdrName -> RnM (RuleDecls Name, FreeVars)
721 rnHsRuleDecls (HsRules src rules)
722 = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules
723 ; return (HsRules src rn_rules,fvs) }
724
725 rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
726 rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
727 = do { let rdr_names_w_loc = map get_var vars
728 ; checkDupRdrNames rdr_names_w_loc
729 ; checkShadowedRdrNames rdr_names_w_loc
730 ; names <- newLocalBndrsRn rdr_names_w_loc
731 ; bindHsRuleVars (snd $ unLoc rule_name) vars names $ \ vars' ->
732 do { (lhs', fv_lhs') <- rnLExpr lhs
733 ; (rhs', fv_rhs') <- rnLExpr rhs
734 ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'
735 ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
736 fv_lhs' `plusFV` fv_rhs') } }
737 where
738 get_var (L _ (RuleBndrSig v _)) = v
739 get_var (L _ (RuleBndr v)) = v
740
741 bindHsRuleVars :: RuleName -> [LRuleBndr RdrName] -> [Name]
742 -> ([LRuleBndr Name] -> RnM (a, FreeVars))
743 -> RnM (a, FreeVars)
744 bindHsRuleVars rule_name vars names thing_inside
745 = go vars names $ \ vars' ->
746 bindLocalNamesFV names (thing_inside vars')
747 where
748 doc = RuleCtx rule_name
749
750 go (L l (RuleBndr (L loc _)) : vars) (n : ns) thing_inside
751 = go vars ns $ \ vars' ->
752 thing_inside (L l (RuleBndr (L loc n)) : vars')
753
754 go (L l (RuleBndrSig (L loc _) bsig) : vars) (n : ns) thing_inside
755 = rnHsBndrSig doc bsig $ \ bsig' ->
756 go vars ns $ \ vars' ->
757 thing_inside (L l (RuleBndrSig (L loc n) bsig') : vars')
758
759 go [] [] thing_inside = thing_inside []
760 go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
761
762 {-
763 Note [Rule LHS validity checking]
764 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
765 Check the shape of a transformation rule LHS. Currently we only allow
766 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
767 @forall@'d variables.
768
769 We used restrict the form of the 'ei' to prevent you writing rules
770 with LHSs with a complicated desugaring (and hence unlikely to match);
771 (e.g. a case expression is not allowed: too elaborate.)
772
773 But there are legitimate non-trivial args ei, like sections and
774 lambdas. So it seems simmpler not to check at all, and that is why
775 check_e is commented out.
776 -}
777
778 checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM ()
779 checkValidRule rule_name ids lhs' fv_lhs'
780 = do { -- Check for the form of the LHS
781 case (validRuleLhs ids lhs') of
782 Nothing -> return ()
783 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
784
785 -- Check that LHS vars are all bound
786 ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
787 ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
788
789 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
790 -- Nothing => OK
791 -- Just e => Not ok, and e is the offending expression
792 validRuleLhs foralls lhs
793 = checkl lhs
794 where
795 checkl (L _ e) = check e
796
797 check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
798 check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2
799 check (HsVar v) | v `notElem` foralls = Nothing
800 check other = Just other -- Failure
801
802 -- Check an argument
803 checkl_e (L _ _e) = Nothing -- Was (check_e e); see Note [Rule LHS validity checking]
804
805 {- Commented out; see Note [Rule LHS validity checking] above
806 check_e (HsVar v) = Nothing
807 check_e (HsPar e) = checkl_e e
808 check_e (HsLit e) = Nothing
809 check_e (HsOverLit e) = Nothing
810
811 check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
812 check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2
813 check_e (NegApp e _) = checkl_e e
814 check_e (ExplicitList _ es) = checkl_es es
815 check_e other = Just other -- Fails
816
817 checkl_es es = foldr (mplus . checkl_e) Nothing es
818 -}
819
820 badRuleVar :: FastString -> Name -> SDoc
821 badRuleVar name var
822 = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon,
823 ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+>
824 ptext (sLit "does not appear on left hand side")]
825
826 badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
827 badRuleLhsErr name lhs bad_e
828 = sep [ptext (sLit "Rule") <+> ftext name <> colon,
829 nest 4 (vcat [ptext (sLit "Illegal expression:") <+> ppr bad_e,
830 ptext (sLit "in left-hand side:") <+> ppr lhs])]
831 $$
832 ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd")
833
834 {-
835 *********************************************************
836 * *
837 \subsection{Vectorisation declarations}
838 * *
839 *********************************************************
840 -}
841
842 rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars)
843 -- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly
844 -- typecheck a complex right-hand side without invoking 'vectType' from the vectoriser.
845 rnHsVectDecl (HsVect s var rhs@(L _ (HsVar _)))
846 = do { var' <- lookupLocatedOccRn var
847 ; (rhs', fv_rhs) <- rnLExpr rhs
848 ; return (HsVect s var' rhs', fv_rhs `addOneFV` unLoc var')
849 }
850 rnHsVectDecl (HsVect _ _var _rhs)
851 = failWith $ vcat
852 [ ptext (sLit "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma")
853 , ptext (sLit "must be an identifier")
854 ]
855 rnHsVectDecl (HsNoVect s var)
856 = do { var' <- lookupLocatedTopBndrRn var -- only applies to local (not imported) names
857 ; return (HsNoVect s var', unitFV (unLoc var'))
858 }
859 rnHsVectDecl (HsVectTypeIn s isScalar tycon Nothing)
860 = do { tycon' <- lookupLocatedOccRn tycon
861 ; return (HsVectTypeIn s isScalar tycon' Nothing, unitFV (unLoc tycon'))
862 }
863 rnHsVectDecl (HsVectTypeIn s isScalar tycon (Just rhs_tycon))
864 = do { tycon' <- lookupLocatedOccRn tycon
865 ; rhs_tycon' <- lookupLocatedOccRn rhs_tycon
866 ; return ( HsVectTypeIn s isScalar tycon' (Just rhs_tycon')
867 , mkFVs [unLoc tycon', unLoc rhs_tycon'])
868 }
869 rnHsVectDecl (HsVectTypeOut _ _ _)
870 = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'"
871 rnHsVectDecl (HsVectClassIn s cls)
872 = do { cls' <- lookupLocatedOccRn cls
873 ; return (HsVectClassIn s cls', unitFV (unLoc cls'))
874 }
875 rnHsVectDecl (HsVectClassOut _)
876 = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
877 rnHsVectDecl (HsVectInstIn instTy)
878 = do { (instTy', fvs) <- rnLHsInstType (text "In a VECTORISE pragma") instTy
879 ; return (HsVectInstIn instTy', fvs)
880 }
881 rnHsVectDecl (HsVectInstOut _)
882 = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"
883
884 {-
885 *********************************************************
886 * *
887 \subsection{Type, class and iface sig declarations}
888 * *
889 *********************************************************
890
891 @rnTyDecl@ uses the `global name function' to create a new type
892 declaration in which local names have been replaced by their original
893 names, reporting any unknown names.
894
895 Renaming type variables is a pain. Because they now contain uniques,
896 it is necessary to pass in an association list which maps a parsed
897 tyvar to its @Name@ representation.
898 In some cases (type signatures of values),
899 it is even necessary to go over the type first
900 in order to get the set of tyvars used by it, make an assoc list,
901 and then go over it again to rename the tyvars!
902 However, we can also do some scoping checks at the same time.
903
904
905 Note [Extra dependencies from .hs-boot files]
906 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
907 Consider the following case:
908
909 A.hs-boot
910 module A where
911 data A1
912
913 B.hs
914 module B where
915 import {-# SOURCE #-} A
916 type DisguisedA1 = A1
917 data B1 = B1 DisguisedA1
918
919 A.hs
920 module A where
921 import B
922 data A2 = A2 A1
923 data A1 = A1 B1
924
925 Here A1 is really recursive (via B1), but we won't see that easily when
926 doing dependency analysis when compiling A.hs
927
928 To handle this problem, we add a dependency
929 - from every local declaration
930 - to everything that comes from this module's .hs-boot file.
931 In this case, we'll add and edges
932 - from A2 to A1 (but that edge is there already)
933 - from A1 to A1 (which is new)
934
935 Well, not quite *every* declaration. Imagine module A
936 above had another datatype declaration:
937
938 data A3 = A3 Int
939
940 Even though A3 has a dependency (on Int), all its dependencies are from things
941 that live on other packages. Since we don't have mutual dependencies across
942 packages, it is safe not to add the dependencies on the .hs-boot stuff to A2.
943
944 Hence function Name.thisPackageImport.
945
946 See also Note [Grouping of type and class declarations] in TcTyClsDecls.
947 -}
948
949
950 rnTyClDecls :: Maybe FreeVars -> [TyClGroup RdrName]
951 -> RnM ([TyClGroup Name], FreeVars)
952 -- Rename the declarations and do depedency analysis on them
953 rnTyClDecls extra_deps tycl_ds
954 = do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupConcat tycl_ds)
955 ; let decl_names = mkNameSet (map (tcdName . unLoc . fst) ds_w_fvs)
956 ; role_annot_env <- rnRoleAnnots decl_names (concatMap group_roles tycl_ds)
957 ; this_mod <- getModule
958 ; let add_boot_deps :: FreeVars -> FreeVars
959 -- See Note [Extra dependencies from .hs-boot files]
960 add_boot_deps fvs
961 | Just extra <- extra_deps
962 , has_local_imports fvs = fvs `plusFV` extra
963 | otherwise = fvs
964
965 has_local_imports fvs
966 = foldNameSet ((||) . nameIsHomePackageImport this_mod)
967 False fvs
968
969 ds_w_fvs' = mapSnd add_boot_deps ds_w_fvs
970
971 sccs :: [SCC (LTyClDecl Name)]
972 sccs = depAnalTyClDecls ds_w_fvs'
973
974 all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs'
975
976 raw_groups = map flattenSCC sccs
977 -- See Note [Role annotations in the renamer]
978 (groups, orphan_roles)
979 = foldr (\group (groups_acc, orphans_acc) ->
980 let names = map (tcdName . unLoc) group
981 roles = mapMaybe (lookupNameEnv orphans_acc) names
982 orphans' = delListFromNameEnv orphans_acc names
983 -- there doesn't seem to be an interface to
984 -- do the above more efficiently
985 in ( TyClGroup { group_tyclds = group
986 , group_roles = roles } : groups_acc
987 , orphans' )
988 )
989 ([], role_annot_env)
990 raw_groups
991
992 ; mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles)
993 ; traceRn (text "rnTycl" <+> (ppr ds_w_fvs $$ ppr sccs))
994 ; return (groups, all_fvs) }
995
996 rnTyClDecl :: TyClDecl RdrName
997 -> RnM (TyClDecl Name, FreeVars)
998
999 -- All flavours of type family declarations ("type family", "newtype family",
1000 -- and "data family"), both top level and (for an associated type)
1001 -- in a class decl
1002 rnTyClDecl (FamDecl { tcdFam = decl })
1003 = do { (decl', fvs) <- rnFamDecl Nothing decl
1004 ; return (FamDecl decl', fvs) }
1005
1006 rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs })
1007 = do { tycon' <- lookupLocatedTopBndrRn tycon
1008 ; let kvs = fst (extractHsTyRdrTyVars rhs)
1009 doc = TySynCtx tycon
1010 ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs)
1011 ; ((tyvars', rhs'), fvs) <- bindHsTyVars doc Nothing kvs tyvars $
1012 \ tyvars' ->
1013 do { (rhs', fvs) <- rnTySyn doc rhs
1014 ; return ((tyvars', rhs'), fvs) }
1015 ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
1016 , tcdRhs = rhs', tcdFVs = fvs }, fvs) }
1017
1018 -- "data", "newtype" declarations
1019 -- both top level and (for an associated type) in an instance decl
1020 rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn })
1021 = do { tycon' <- lookupLocatedTopBndrRn tycon
1022 ; let kvs = extractDataDefnKindVars defn
1023 doc = TyDataCtx tycon
1024 ; traceRn (text "rntycl-data" <+> ppr tycon <+> ppr kvs)
1025 ; ((tyvars', defn'), fvs) <- bindHsTyVars doc Nothing kvs tyvars $ \ tyvars' ->
1026 do { (defn', fvs) <- rnDataDefn doc defn
1027 ; return ((tyvars', defn'), fvs) }
1028 ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
1029 , tcdDataDefn = defn', tcdFVs = fvs }, fvs) }
1030
1031 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls,
1032 tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
1033 tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
1034 tcdDocs = docs})
1035 = do { lcls' <- lookupLocatedTopBndrRn lcls
1036 ; let cls' = unLoc lcls'
1037 kvs = [] -- No scoped kind vars except those in
1038 -- kind signatures on the tyvars
1039
1040 -- Tyvars scope over superclass context and method signatures
1041 ; ((tyvars', context', fds', ats', sigs'), stuff_fvs)
1042 <- bindHsTyVars cls_doc Nothing kvs tyvars $ \ tyvars' -> do
1043 -- Checks for distinct tyvars
1044 { (context', cxt_fvs) <- rnContext cls_doc context
1045 ; fds' <- rnFds fds
1046 -- The fundeps have no free variables
1047 ; (ats', fv_ats) <- rnATDecls cls' ats
1048 ; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs
1049 ; let fvs = cxt_fvs `plusFV`
1050 sig_fvs `plusFV`
1051 fv_ats
1052 ; return ((tyvars', context', fds', ats', sigs'), fvs) }
1053
1054 ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltEqn cls') at_defs
1055
1056 -- No need to check for duplicate associated type decls
1057 -- since that is done by RnNames.extendGlobalRdrEnvRn
1058
1059 -- Check the signatures
1060 -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
1061 ; let sig_rdr_names_w_locs = [op | L _ (TypeSig ops _ _) <- sigs, op <- ops]
1062 ; checkDupRdrNames sig_rdr_names_w_locs
1063 -- Typechecker is responsible for checking that we only
1064 -- give default-method bindings for things in this class.
1065 -- The renamer *could* check this for class decls, but can't
1066 -- for instance decls.
1067
1068 -- The newLocals call is tiresome: given a generic class decl
1069 -- class C a where
1070 -- op :: a -> a
1071 -- op {| x+y |} (Inl a) = ...
1072 -- op {| x+y |} (Inr b) = ...
1073 -- op {| a*b |} (a*b) = ...
1074 -- we want to name both "x" tyvars with the same unique, so that they are
1075 -- easy to group together in the typechecker.
1076 ; (mbinds', meth_fvs)
1077 <- extendTyVarEnvForMethodBinds (hsLKiTyVarNames tyvars') $
1078 -- No need to check for duplicate method signatures
1079 -- since that is done by RnNames.extendGlobalRdrEnvRn
1080 -- and the methods are already in scope
1081 rnMethodBinds cls' (mkSigTvFn sigs') mbinds
1082
1083 -- Haddock docs
1084 ; docs' <- mapM (wrapLocM rnDocDecl) docs
1085
1086 ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs
1087 ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',
1088 tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
1089 tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
1090 tcdDocs = docs', tcdFVs = all_fvs },
1091 all_fvs ) }
1092 where
1093 cls_doc = ClassDeclCtx lcls
1094
1095 -- "type" and "type instance" declarations
1096 rnTySyn :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
1097 rnTySyn doc rhs = rnLHsType doc rhs
1098
1099 -- | Renames role annotations, returning them as the values in a NameEnv
1100 -- and checks for duplicate role annotations.
1101 -- It is quite convenient to do both of these in the same place.
1102 -- See also Note [Role annotations in the renamer]
1103 rnRoleAnnots :: NameSet -- ^ of the decls in this group
1104 -> [LRoleAnnotDecl RdrName]
1105 -> RnM (NameEnv (LRoleAnnotDecl Name))
1106 rnRoleAnnots decl_names role_annots
1107 = do { -- check for duplicates *before* renaming, to avoid lumping
1108 -- together all the unboundNames
1109 let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots
1110 role_annots_cmp (L _ annot1) (L _ annot2)
1111 = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2
1112 ; mapM_ dupRoleAnnotErr dup_annots
1113 ; role_annots' <- mapM (wrapLocM rn_role_annot1) no_dups
1114 -- some of the role annots will be unbound; we don't wish
1115 -- to include these
1116 ; return $ mkNameEnv [ (name, ra)
1117 | ra <- role_annots'
1118 , let name = roleAnnotDeclName (unLoc ra)
1119 , not (isUnboundName name) ] }
1120 where
1121 rn_role_annot1 (RoleAnnotDecl tycon roles)
1122 = do { -- the name is an *occurrence*, but look it up only in the
1123 -- decls defined in this group (see #10263)
1124 tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt decl_names)
1125 (text "role annotation")
1126 tycon
1127 ; return $ RoleAnnotDecl tycon' roles }
1128
1129 dupRoleAnnotErr :: [LRoleAnnotDecl RdrName] -> RnM ()
1130 dupRoleAnnotErr [] = panic "dupRoleAnnotErr"
1131 dupRoleAnnotErr list
1132 = addErrAt loc $
1133 hang (text "Duplicate role annotations for" <+>
1134 quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
1135 2 (vcat $ map pp_role_annot sorted_list)
1136 where
1137 sorted_list = sortBy cmp_annot list
1138 (L loc first_decl : _) = sorted_list
1139
1140 pp_role_annot (L loc decl) = hang (ppr decl)
1141 4 (text "-- written at" <+> ppr loc)
1142
1143 cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2
1144
1145 orphanRoleAnnotErr :: LRoleAnnotDecl Name -> RnM ()
1146 orphanRoleAnnotErr (L loc decl)
1147 = addErrAt loc $
1148 hang (text "Role annotation for a type previously declared:")
1149 2 (ppr decl) $$
1150 parens (text "The role annotation must be given where" <+>
1151 quotes (ppr $ roleAnnotDeclName decl) <+>
1152 text "is declared.")
1153
1154 rnDataDefn :: HsDocContext -> HsDataDefn RdrName -> RnM (HsDataDefn Name, FreeVars)
1155 rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1156 , dd_ctxt = context, dd_cons = condecls
1157 , dd_kindSig = sig, dd_derivs = derivs })
1158 = do { checkTc (h98_style || null (unLoc context))
1159 (badGadtStupidTheta doc)
1160
1161 ; (sig', sig_fvs) <- rnLHsMaybeKind doc sig
1162 ; (context', fvs1) <- rnContext doc context
1163 ; (derivs', fvs3) <- rn_derivs derivs
1164
1165 -- For the constructor declarations, drop the LocalRdrEnv
1166 -- in the GADT case, where the type variables in the declaration
1167 -- do not scope over the constructor signatures
1168 -- data T a where { T1 :: forall b. b-> b }
1169 ; let { zap_lcl_env | h98_style = \ thing -> thing
1170 | otherwise = setLocalRdrEnv emptyLocalRdrEnv }
1171 ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls
1172 -- No need to check for duplicate constructor decls
1173 -- since that is done by RnNames.extendGlobalRdrEnvRn
1174
1175 ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
1176 con_fvs `plusFV` sig_fvs
1177 ; return ( HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1178 , dd_ctxt = context', dd_kindSig = sig'
1179 , dd_cons = condecls'
1180 , dd_derivs = derivs' }
1181 , all_fvs )
1182 }
1183 where
1184 h98_style = case condecls of -- Note [Stupid theta]
1185 L _ (ConDecl { con_res = ResTyGADT {} }) : _ -> False
1186 _ -> True
1187
1188 rn_derivs Nothing = return (Nothing, emptyFVs)
1189 rn_derivs (Just (L ld ds)) = do { (ds', fvs) <- rnLHsTypes doc ds
1190 ; return (Just (L ld ds'), fvs) }
1191
1192 badGadtStupidTheta :: HsDocContext -> SDoc
1193 badGadtStupidTheta _
1194 = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
1195 ptext (sLit "(You can put a context on each contructor, though.)")]
1196
1197 rnFamDecl :: Maybe Name
1198 -- Just cls => this FamilyDecl is nested
1199 -- inside an *class decl* for cls
1200 -- used for associated types
1201 -> FamilyDecl RdrName
1202 -> RnM (FamilyDecl Name, FreeVars)
1203 rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
1204 , fdInfo = info, fdKindSig = kind })
1205 = do { ((tycon', tyvars', kind'), fv1) <-
1206 bindHsTyVars fmly_doc mb_cls kvs tyvars $ \tyvars' ->
1207 do { tycon' <- lookupLocatedTopBndrRn tycon
1208 ; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind
1209 ; return ((tycon', tyvars', kind'), fv_kind) }
1210 ; (info', fv2) <- rn_info info
1211 ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars'
1212 , fdInfo = info', fdKindSig = kind' }
1213 , fv1 `plusFV` fv2) }
1214 where
1215 fmly_doc = TyFamilyCtx tycon
1216 kvs = extractRdrKindSigVars kind
1217
1218 rn_info (ClosedTypeFamily (Just eqns))
1219 = do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns
1220 -- no class context,
1221 ; return (ClosedTypeFamily (Just eqns'), fvs) }
1222 rn_info (ClosedTypeFamily Nothing)
1223 = return (ClosedTypeFamily Nothing, emptyFVs)
1224 rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
1225 rn_info DataFamily = return (DataFamily, emptyFVs)
1226
1227 {-
1228 Note [Stupid theta]
1229 ~~~~~~~~~~~~~~~~~~~
1230 Trac #3850 complains about a regression wrt 6.10 for
1231 data Show a => T a
1232 There is no reason not to allow the stupid theta if there are no data
1233 constructors. It's still stupid, but does no harm, and I don't want
1234 to cause programs to break unnecessarily (notably HList). So if there
1235 are no data constructors we allow h98_style = True
1236 -}
1237
1238 depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)]
1239 -- See Note [Dependency analysis of type and class decls]
1240 depAnalTyClDecls ds_w_fvs
1241 = stronglyConnCompFromEdgedVertices edges
1242 where
1243 edges = [ (d, tcdName (unLoc d), map get_parent (nameSetElems fvs))
1244 | (d, fvs) <- ds_w_fvs ]
1245
1246 -- We also need to consider data constructor names since
1247 -- they may appear in types because of promotion.
1248 get_parent n = lookupNameEnv assoc_env n `orElse` n
1249
1250 assoc_env :: NameEnv Name -- Maps a data constructor back
1251 -- to its parent type constructor
1252 assoc_env = mkNameEnv $ concat assoc_env_list
1253 assoc_env_list = do
1254 (L _ d, _) <- ds_w_fvs
1255 case d of
1256 ClassDecl { tcdLName = L _ cls_name
1257 , tcdATs = ats }
1258 -> do L _ (FamilyDecl { fdLName = L _ fam_name }) <- ats
1259 return [(fam_name, cls_name)]
1260 DataDecl { tcdLName = L _ data_name
1261 , tcdDataDefn = HsDataDefn { dd_cons = cons } }
1262 -> do L _ dc <- cons
1263 return $ zip (map unLoc $ con_names dc) (repeat data_name)
1264 _ -> []
1265
1266 {-
1267 Note [Dependency analysis of type and class decls]
1268 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1269 We need to do dependency analysis on type and class declarations
1270 else we get bad error messages. Consider
1271
1272 data T f a = MkT f a
1273 data S f a = MkS f (T f a)
1274
1275 This has a kind error, but the error message is better if you
1276 check T first, (fixing its kind) and *then* S. If you do kind
1277 inference together, you might get an error reported in S, which
1278 is jolly confusing. See Trac #4875
1279
1280 Note [Role annotations in the renamer]
1281 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1282 We must ensure that a type's role annotation is put in the same group as the
1283 proper type declaration. This is because role annotations are needed during
1284 type-checking when creating the type's TyCon. So, rnRoleAnnots builds a
1285 NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that
1286 type, if any. Then, this map can be used to add the role annotations to the
1287 groups after dependency analysis.
1288
1289 This process checks for duplicate role annotations, where we must be careful
1290 to do the check *before* renaming to avoid calling all unbound names duplicates
1291 of one another.
1292
1293 The renaming process, as usual, might identify and report errors for unbound
1294 names. We exclude the annotations for unbound names in the annotation
1295 environment to avoid spurious errors for orphaned annotations.
1296
1297 We then (in rnTyClDecls) do a check for orphan role annotations (role
1298 annotations without an accompanying type decl). The check works by folding
1299 over raw_groups (of type [[TyClDecl Name]]), selecting out the relevant
1300 role declarations for each group, as well as diminishing the annotation
1301 environment. After the fold is complete, anything left over in the name
1302 environment must be an orphan, and errors are generated.
1303
1304 An earlier version of this algorithm short-cut the orphan check by renaming
1305 only with names declared in this module. But, this check is insufficient in
1306 the case of staged module compilation (Template Haskell, GHCi).
1307 See #8485. With the new lookup process (which includes types declared in other
1308 modules), we get better error messages, too.
1309
1310 *********************************************************
1311 * *
1312 \subsection{Support code for type/data declarations}
1313 * *
1314 *********************************************************
1315 -}
1316
1317 ---------------
1318 badAssocRhs :: [Name] -> RnM ()
1319 badAssocRhs ns
1320 = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions")
1321 <+> pprWithCommas (quotes . ppr) ns)
1322 2 (ptext (sLit "All such variables must be bound on the LHS")))
1323
1324 -----------------
1325 rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
1326 rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
1327
1328 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars)
1329 rnConDecl decl@(ConDecl { con_names = names, con_qvars = tvs
1330 , con_cxt = lcxt@(L loc cxt), con_details = details
1331 , con_res = res_ty, con_doc = mb_doc
1332 , con_old_rec = old_rec, con_explicit = expl })
1333 = do { mapM_ (addLocM checkConName) names
1334 ; when old_rec (addWarn (deprecRecSyntax decl))
1335 ; new_names <- mapM lookupLocatedTopBndrRn names
1336
1337 -- For H98 syntax, the tvs are the existential ones
1338 -- For GADT syntax, the tvs are all the quantified tyvars
1339 -- Hence the 'filter' in the ResTyH98 case only
1340 ; rdr_env <- getLocalRdrEnv
1341 ; let arg_tys = hsConDeclArgTys details
1342 (free_kvs, free_tvs) = case res_ty of
1343 ResTyH98 -> filterInScope rdr_env (get_rdr_tvs arg_tys)
1344 ResTyGADT _ ty -> get_rdr_tvs (ty : arg_tys)
1345
1346 -- With an Explicit forall, check for unused binders
1347 -- With Implicit, find the mentioned ones, and use them as binders
1348 -- With Qualified, do the same as with Implicit, but give a warning
1349 -- See Note [Context quantification]
1350 ; new_tvs <- case expl of
1351 Implicit -> return (mkHsQTvs (userHsTyVarBndrs loc free_tvs))
1352 Qualified -> do { warnContextQuantification (docOfHsDocContext doc)
1353 (userHsTyVarBndrs loc free_tvs)
1354 ; return (mkHsQTvs (userHsTyVarBndrs loc free_tvs)) }
1355 Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs free_tvs
1356 ; return tvs }
1357
1358 ; mb_doc' <- rnMbLHsDoc mb_doc
1359
1360 ; bindHsTyVars doc Nothing free_kvs new_tvs $ \new_tyvars -> do
1361 { (new_context, fvs1) <- rnContext doc lcxt
1362 ; (new_details, fvs2) <- rnConDeclDetails doc details
1363 ; (new_details', new_res_ty, fvs3)
1364 <- rnConResult doc (map unLoc new_names) new_details res_ty
1365 ; return (decl { con_names = new_names, con_qvars = new_tyvars
1366 , con_cxt = new_context, con_details = new_details'
1367 , con_res = new_res_ty, con_doc = mb_doc' },
1368 fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
1369 where
1370 doc = ConDeclCtx names
1371 get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys)
1372
1373 rnConResult :: HsDocContext -> [Name]
1374 -> HsConDetails (LHsType Name) (Located [LConDeclField Name])
1375 -> ResType (LHsType RdrName)
1376 -> RnM (HsConDetails (LHsType Name) (Located [LConDeclField Name]),
1377 ResType (LHsType Name), FreeVars)
1378 rnConResult _ _ details ResTyH98 = return (details, ResTyH98, emptyFVs)
1379 rnConResult doc _con details (ResTyGADT ls ty)
1380 = do { (ty', fvs) <- rnLHsType doc ty
1381 ; let (arg_tys, res_ty) = splitHsFunType ty'
1382 -- We can finally split it up,
1383 -- now the renamer has dealt with fixities
1384 -- See Note [Sorting out the result type] in RdrHsSyn
1385
1386 ; case details of
1387 InfixCon {} -> pprPanic "rnConResult" (ppr ty)
1388 -- See Note [Sorting out the result type] in RdrHsSyn
1389
1390 RecCon {} -> do { unless (null arg_tys)
1391 (addErr (badRecResTy (docOfHsDocContext doc)))
1392 ; return (details, ResTyGADT ls res_ty, fvs) }
1393
1394 PrefixCon {} -> return (PrefixCon arg_tys, ResTyGADT ls res_ty, fvs)}
1395
1396 rnConDeclDetails
1397 :: HsDocContext
1398 -> HsConDetails (LHsType RdrName) (Located [LConDeclField RdrName])
1399 -> RnM (HsConDetails (LHsType Name) (Located [LConDeclField Name]), FreeVars)
1400 rnConDeclDetails doc (PrefixCon tys)
1401 = do { (new_tys, fvs) <- rnLHsTypes doc tys
1402 ; return (PrefixCon new_tys, fvs) }
1403
1404 rnConDeclDetails doc (InfixCon ty1 ty2)
1405 = do { (new_ty1, fvs1) <- rnLHsType doc ty1
1406 ; (new_ty2, fvs2) <- rnLHsType doc ty2
1407 ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
1408
1409 rnConDeclDetails doc (RecCon (L l fields))
1410 = do { (new_fields, fvs) <- rnConDeclFields doc fields
1411 -- No need to check for duplicate fields
1412 -- since that is done by RnNames.extendGlobalRdrEnvRn
1413 ; return (RecCon (L l new_fields), fvs) }
1414
1415 -------------------------------------------------
1416 deprecRecSyntax :: ConDecl RdrName -> SDoc
1417 deprecRecSyntax decl
1418 = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_names decl))
1419 <+> ptext (sLit "uses deprecated syntax")
1420 , ptext (sLit "Instead, use the form")
1421 , nest 2 (ppr decl) ] -- Pretty printer uses new form
1422
1423 badRecResTy :: SDoc -> SDoc
1424 badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
1425
1426 {-
1427 *********************************************************
1428 * *
1429 \subsection{Support code for type/data declarations}
1430 * *
1431 *********************************************************
1432
1433 Get the mapping from constructors to fields for this module.
1434 It's convenient to do this after the data type decls have been renamed
1435 -}
1436
1437 extendRecordFieldEnv :: [TyClGroup RdrName] -> [LInstDecl RdrName] -> TcM TcGblEnv
1438 extendRecordFieldEnv tycl_decls inst_decls
1439 = do { tcg_env <- getGblEnv
1440 ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
1441 ; return (tcg_env { tcg_field_env = field_env' }) }
1442 where
1443 -- we want to lookup:
1444 -- (a) a datatype constructor
1445 -- (b) a record field
1446 -- knowing that they're from this module.
1447 -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn_maybe,
1448 -- which keeps only the local ones.
1449 lookup x = do { x' <- lookupLocatedTopBndrRn x
1450 ; return $ unLoc x'}
1451
1452 all_data_cons :: [ConDecl RdrName]
1453 all_data_cons = [con | HsDataDefn { dd_cons = cons } <- all_ty_defs
1454 , L _ con <- cons ]
1455 all_ty_defs = [ defn | L _ (DataDecl { tcdDataDefn = defn })
1456 <- tyClGroupConcat tycl_decls ]
1457 ++ map dfid_defn (instDeclDataFamInsts inst_decls)
1458 -- Do not forget associated types!
1459
1460 get_con (ConDecl { con_names = cons, con_details = RecCon flds })
1461 (RecFields env fld_set)
1462 = do { cons' <- mapM lookup cons
1463 ; flds' <- mapM lookup (concatMap (cd_fld_names . unLoc)
1464 (unLoc flds))
1465 ; let env' = foldl (\e c -> extendNameEnv e c flds') env cons'
1466
1467 fld_set' = extendNameSetList fld_set flds'
1468 ; return $ (RecFields env' fld_set') }
1469 get_con _ env = return env
1470
1471 {-
1472 *********************************************************
1473 * *
1474 \subsection{Support code to rename types}
1475 * *
1476 *********************************************************
1477 -}
1478
1479 rnFds :: [Located (FunDep (Located RdrName))]
1480 -> RnM [Located (FunDep (Located Name))]
1481 rnFds fds
1482 = mapM (wrapLocM rn_fds) fds
1483 where
1484 rn_fds (tys1, tys2)
1485 = do { tys1' <- rnHsTyVars tys1
1486 ; tys2' <- rnHsTyVars tys2
1487 ; return (tys1', tys2') }
1488
1489 rnHsTyVars :: [Located RdrName] -> RnM [Located Name]
1490 rnHsTyVars tvs = mapM rnHsTyVar tvs
1491
1492 rnHsTyVar :: Located RdrName -> RnM (Located Name)
1493 rnHsTyVar (L l tyvar) = do
1494 tyvar' <- lookupOccRn tyvar
1495 return (L l tyvar')
1496
1497 {-
1498 *********************************************************
1499 * *
1500 findSplice
1501 * *
1502 *********************************************************
1503
1504 This code marches down the declarations, looking for the first
1505 Template Haskell splice. As it does so it
1506 a) groups the declarations into a HsGroup
1507 b) runs any top-level quasi-quotes
1508 -}
1509
1510 findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1511 findSplice ds = addl emptyRdrGroup ds
1512
1513 addl :: HsGroup RdrName -> [LHsDecl RdrName]
1514 -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1515 -- This stuff reverses the declarations (again) but it doesn't matter
1516 addl gp [] = return (gp, Nothing)
1517 addl gp (L l d : ds) = add gp l d ds
1518
1519
1520 add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName]
1521 -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1522
1523 add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
1524 = do { -- We've found a top-level splice. If it is an *implicit* one
1525 -- (i.e. a naked top level expression)
1526 case flag of
1527 ExplicitSplice -> return ()
1528 ImplicitSplice -> do { th_on <- xoptM Opt_TemplateHaskell
1529 ; unless th_on $ setSrcSpan loc $
1530 failWith badImplicitSplice }
1531
1532 ; return (gp, Just (splice, ds)) }
1533 where
1534 badImplicitSplice = ptext (sLit "Parse error: naked expression at top level")
1535 $$ ptext (sLit "Perhaps you intended to use TemplateHaskell")
1536
1537 -- Class declarations: pull out the fixity signatures to the top
1538 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
1539 | isClassDecl d
1540 = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
1541 addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
1542 | otherwise
1543 = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
1544
1545 -- Signatures: fixity sigs go a different place than all others
1546 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
1547 = addl (gp {hs_fixds = L l f : ts}) ds
1548 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
1549 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
1550
1551 -- Value declarations: use add_bind
1552 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
1553 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
1554
1555 -- Role annotations: added to the TyClGroup
1556 add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD d) ds
1557 = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds
1558
1559 -- The rest are routine
1560 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
1561 = addl (gp { hs_instds = L l d : ts }) ds
1562 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
1563 = addl (gp { hs_derivds = L l d : ts }) ds
1564 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
1565 = addl (gp { hs_defds = L l d : ts }) ds
1566 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
1567 = addl (gp { hs_fords = L l d : ts }) ds
1568 add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
1569 = addl (gp { hs_warnds = L l d : ts }) ds
1570 add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
1571 = addl (gp { hs_annds = L l d : ts }) ds
1572 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
1573 = addl (gp { hs_ruleds = L l d : ts }) ds
1574 add gp@(HsGroup {hs_vects = ts}) l (VectD d) ds
1575 = addl (gp { hs_vects = L l d : ts }) ds
1576 add gp l (DocD d) ds
1577 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
1578
1579 add_tycld :: LTyClDecl a -> [TyClGroup a] -> [TyClGroup a]
1580 add_tycld d [] = [TyClGroup { group_tyclds = [d], group_roles = [] }]
1581 add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
1582 = ds { group_tyclds = d : tyclds } : dss
1583
1584 add_role_annot :: LRoleAnnotDecl a -> [TyClGroup a] -> [TyClGroup a]
1585 add_role_annot d [] = [TyClGroup { group_tyclds = [], group_roles = [d] }]
1586 add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
1587 = tycls { group_roles = d : roles } : rest
1588
1589 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
1590 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
1591 add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
1592
1593 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
1594 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
1595 add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"