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