2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[RnSource]{Main pass of renamer}
8 rnSrcDecls, addTcgDUs, rnTyClDecls, findSplice
11 #include "HsVersions.h"
13 import {-# SOURCE #-} RnExpr( rnLExpr )
15 import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl )
19 import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc )
20 import RdrHsSyn ( extractHsRhoRdrTyVars )
22 import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext, rnConDeclFields )
23 import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn,
25 import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn,
26 lookupTopBndrRn, lookupLocatedTopBndrRn,
27 lookupOccRn, bindLocalNamesFV,
28 bindLocatedLocalsFV, bindPatSigTyVarsFV,
29 bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn,
30 bindLocalNames, checkDupRdrNames, mapFvRn
32 import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn )
33 import HscTypes ( GenAvailInfo(..), availsToNameSet )
34 import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
37 import ForeignCall ( CCallTarget(..) )
39 import HscTypes ( Warnings(..), plusWarns )
40 import Class ( FunDep )
41 import Name ( Name, nameOccName )
47 import Util ( filterOut )
50 import HscTypes ( HscEnv, hsc_dflags )
51 import BasicTypes ( Boxity(..) )
52 import ListSetOps ( findDupsEq )
53 import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
56 import Maybes( orElse )
62 thenM :: Monad a => a b -> (b -> a c) -> a c
65 thenM_ :: Monad a => a b -> a c -> a c
69 @rnSourceDecl@ `renames' declarations.
70 It simultaneously performs dependency analysis and precedence parsing.
71 It also does the following error checks:
74 Checks that tyvars are used properly. This includes checking
75 for undefined tyvars, and tyvars in contexts that are ambiguous.
76 (Some of this checking has now been moved to module @TcMonoType@,
77 since we don't have functional dependency information at this point.)
79 Checks that all variable occurences are defined.
81 Checks the @(..)@ etc constraints in the export list.
86 -- Brings the binders of the group into scope in the appropriate places;
87 -- does NOT assume that anything is in scope already
88 rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
89 -- Rename a HsGroup; used for normal source files *and* hs-boot files
90 rnSrcDecls group@(HsGroup { hs_valds = val_decls,
91 hs_tyclds = tycl_decls,
92 hs_instds = inst_decls,
93 hs_derivds = deriv_decls,
95 hs_warnds = warn_decls,
97 hs_fords = foreign_decls,
98 hs_defds = default_decls,
99 hs_ruleds = rule_decls,
100 hs_vects = vect_decls,
103 -- (A) Process the fixity declarations, creating a mapping from
104 -- FastStrings to FixItems.
105 -- Also checks for duplcates.
106 local_fix_env <- makeMiniFixityEnv fix_decls;
108 -- (B) Bring top level binders (and their fixities) into scope,
109 -- *except* for the value bindings, which get brought in below.
110 -- However *do* include class ops, data constructors
111 -- And for hs-boot files *do* include the value signatures
112 tc_avails <- getLocalNonValBinders group ;
113 tc_envs <- extendGlobalRdrEnvRn tc_avails local_fix_env ;
114 setEnvs tc_envs $ do {
116 failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
118 -- (C) Extract the mapping from data constructors to field names and
119 -- extend the record field env.
120 -- This depends on the data constructors and field names being in
121 -- scope from (B) above
122 inNewEnv (extendRecordFieldEnv tycl_decls inst_decls) $ \ _ -> do {
124 -- (D) Rename the left-hand sides of the value bindings.
125 -- This depends on everything from (B) being in scope,
126 -- and on (C) for resolving record wild cards.
127 -- It uses the fixity env from (A) to bind fixities for view patterns.
128 new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
129 -- bind the LHSes (and their fixities) in the global rdr environment
130 let { val_binders = collectHsValBinders new_lhs ;
131 val_bndr_set = mkNameSet val_binders ;
132 all_bndr_set = val_bndr_set `unionNameSets` availsToNameSet tc_avails ;
133 val_avails = map Avail val_binders
135 (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ;
136 setEnvs (tcg_env, tcl_env) $ do {
138 -- Now everything is in scope, as the remaining renaming assumes.
140 -- (E) Rename type and class decls
141 -- (note that value LHSes need to be in scope for default methods)
143 -- You might think that we could build proper def/use information
144 -- for type and class declarations, but they can be involved
145 -- in mutual recursion across modules, and we only do the SCC
146 -- analysis for them in the type checker.
147 -- So we content ourselves with gathering uses only; that
148 -- means we'll only report a declaration as unused if it isn't
149 -- mentioned at all. Ah well.
150 traceRn (text "Start rnTyClDecls") ;
151 (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
153 -- (F) Rename Value declarations right-hand sides
154 traceRn (text "Start rnmono") ;
155 (rn_val_decls, bind_dus) <- rnTopBindsRHS new_lhs ;
156 traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
158 -- (G) Rename Fixity and deprecations
160 -- Rename fixity declarations and error if we try to
161 -- fix something from another module (duplicates were checked in (A))
162 rn_fix_decls <- rnSrcFixityDecls all_bndr_set fix_decls ;
164 -- Rename deprec decls;
165 -- check for duplicates and ensure that deprecated things are defined locally
166 -- at the moment, we don't keep these around past renaming
167 rn_warns <- rnSrcWarnDecls all_bndr_set warn_decls ;
169 -- (H) Rename Everything else
171 (rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ;
172 (rn_rule_decls, src_fvs3) <- setOptM Opt_ScopedTypeVariables $
173 rnList rnHsRuleDecl rule_decls ;
174 -- Inside RULES, scoped type variables are on
175 (rn_vect_decls, src_fvs4) <- rnList rnHsVectDecl vect_decls ;
176 (rn_foreign_decls, src_fvs5) <- rnList rnHsForeignDecl foreign_decls ;
177 (rn_ann_decls, src_fvs6) <- rnList rnAnnDecl ann_decls ;
178 (rn_default_decls, src_fvs7) <- rnList rnDefaultDecl default_decls ;
179 (rn_deriv_decls, src_fvs8) <- rnList rnSrcDerivDecl deriv_decls ;
180 -- Haddock docs; no free vars
181 rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
183 -- (I) Compute the results and return
184 let {rn_group = HsGroup { hs_valds = rn_val_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 } ;
198 tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ;
199 ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ;
200 other_def = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ;
201 other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
202 src_fvs5, src_fvs6, src_fvs7, src_fvs8] ;
203 -- It is tiresome to gather the binders from type and class decls
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
209 final_tcg_env = let tcg_env' = (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 };
214 traceRn (text "finish rnSrc" <+> ppr rn_group) ;
215 traceRn (text "finish Dus" <+> ppr src_dus ) ;
216 return (final_tcg_env, rn_group)
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
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 }
230 rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
231 rnList f xs = mapFvRn (wrapLocFstM f) xs
235 %*********************************************************
239 %*********************************************************
242 rnDocDecl :: DocDecl -> RnM DocDecl
243 rnDocDecl (DocCommentNext doc) = do
244 rn_doc <- rnHsDoc doc
245 return (DocCommentNext rn_doc)
246 rnDocDecl (DocCommentPrev doc) = do
247 rn_doc <- rnHsDoc doc
248 return (DocCommentPrev rn_doc)
249 rnDocDecl (DocCommentNamed str doc) = do
250 rn_doc <- rnHsDoc doc
251 return (DocCommentNamed str rn_doc)
252 rnDocDecl (DocGroup lev doc) = do
253 rn_doc <- rnHsDoc doc
254 return (DocGroup lev rn_doc)
258 %*********************************************************
260 Source-code fixity declarations
262 %*********************************************************
265 rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name]
266 -- Rename the fixity decls, so we can put
267 -- the renamed decls in the renamed syntax tree
268 -- Errors if the thing being fixed is not defined locally.
270 -- The returned FixitySigs are not actually used for anything,
271 -- except perhaps the GHCi API
272 rnSrcFixityDecls bound_names fix_decls
273 = do fix_decls <- mapM rn_decl fix_decls
274 return (concat fix_decls)
276 rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]
277 -- GHC extension: look up both the tycon and data con
278 -- for con-like things; hence returning a list
279 -- If neither are in scope, report an error; otherwise
280 -- return a fixity sig for each (slightly odd)
281 rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity))
282 = setSrcSpan name_loc $
283 -- this lookup will fail if the definition isn't local
284 do names <- lookupLocalDataTcNames bound_names what rdr_name
285 return [ L loc (FixitySig (L name_loc name) fixity)
287 what = ptext (sLit "fixity signature")
291 %*********************************************************
293 Source-code deprecations declarations
295 %*********************************************************
297 Check that the deprecated names are defined, are defined locally, and
298 that there are no duplicate deprecations.
300 It's only imported deprecations, dealt with in RnIfaces, that we
301 gather them together.
304 -- checks that the deprecations are defined locally, and that there are no duplicates
305 rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings
306 rnSrcWarnDecls _bound_names []
309 rnSrcWarnDecls bound_names decls
310 = do { -- check for duplicates
311 ; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups
312 in addErrAt loc (dupWarnDecl lrdr' rdr))
314 ; pairs_s <- mapM (addLocM rn_deprec) decls
315 ; return (WarnSome ((concat pairs_s))) }
317 rn_deprec (Warning rdr_name txt)
318 -- ensures that the names are defined locally
319 = lookupLocalDataTcNames bound_names what rdr_name `thenM` \ names ->
320 return [(nameOccName name, txt) | name <- names]
322 what = ptext (sLit "deprecation")
324 -- look for duplicates among the OccNames;
325 -- we check that the names are defined above
326 -- invt: the lists returned by findDupsEq always have at least two elements
327 warn_rdr_dups = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
328 (map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls)
330 dupWarnDecl :: Located RdrName -> RdrName -> SDoc
331 -- Located RdrName -> DeprecDecl RdrName -> SDoc
332 dupWarnDecl (L loc _) rdr_name
333 = vcat [ptext (sLit "Multiple warning declarations for") <+> quotes (ppr rdr_name),
334 ptext (sLit "also at ") <+> ppr loc]
338 %*********************************************************
340 \subsection{Annotation declarations}
342 %*********************************************************
345 rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars)
346 rnAnnDecl (HsAnnotation provenance expr) = do
347 (provenance', provenance_fvs) <- rnAnnProvenance provenance
348 (expr', expr_fvs) <- rnLExpr expr
349 return (HsAnnotation provenance' expr', provenance_fvs `plusFV` expr_fvs)
351 rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars)
352 rnAnnProvenance provenance = do
353 provenance' <- modifyAnnProvenanceNameM lookupTopBndrRn provenance
354 return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))
357 %*********************************************************
359 \subsection{Default declarations}
361 %*********************************************************
364 rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars)
365 rnDefaultDecl (DefaultDecl tys)
366 = mapFvRn (rnHsTypeFVs doc_str) tys `thenM` \ (tys', fvs) ->
367 return (DefaultDecl tys', fvs)
369 doc_str = text "In a `default' declaration"
372 %*********************************************************
374 \subsection{Foreign declarations}
376 %*********************************************************
379 rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
380 rnHsForeignDecl (ForeignImport name ty spec)
381 = getTopEnv `thenM` \ (topEnv :: HscEnv) ->
382 lookupLocatedTopBndrRn name `thenM` \ name' ->
383 rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
385 -- Mark any PackageTarget style imports as coming from the current package
386 let packageId = thisPackage $ hsc_dflags topEnv
387 spec' = patchForeignImport packageId spec
389 in return (ForeignImport name' ty' spec', fvs)
391 rnHsForeignDecl (ForeignExport name ty spec)
392 = lookupLocatedOccRn name `thenM` \ name' ->
393 rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
394 return (ForeignExport name' ty' spec, fvs `addOneFV` unLoc name')
395 -- NB: a foreign export is an *occurrence site* for name, so
396 -- we add it to the free-variable list. It might, for example,
397 -- be imported from another module
399 fo_decl_msg :: Located RdrName -> SDoc
400 fo_decl_msg name = ptext (sLit "In the foreign declaration for") <+> ppr name
403 -- | For Windows DLLs we need to know what packages imported symbols are from
404 -- to generate correct calls. Imported symbols are tagged with the current
405 -- package, so if they get inlined across a package boundry we'll still
406 -- know where they're from.
408 patchForeignImport :: PackageId -> ForeignImport -> ForeignImport
409 patchForeignImport packageId (CImport cconv safety fs spec)
410 = CImport cconv safety fs (patchCImportSpec packageId spec)
412 patchCImportSpec :: PackageId -> CImportSpec -> CImportSpec
413 patchCImportSpec packageId spec
415 CFunction callTarget -> CFunction $ patchCCallTarget packageId callTarget
418 patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget
419 patchCCallTarget packageId callTarget
421 StaticTarget label Nothing
422 -> StaticTarget label (Just packageId)
430 %*********************************************************
432 \subsection{Instance declarations}
434 %*********************************************************
437 rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
438 rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
439 -- Used for both source and interface file decls
440 = rnHsSigType (text "an instance decl") inst_ty `thenM` \ inst_ty' ->
442 -- Rename the bindings
443 -- The typechecker (not the renamer) checks that all
444 -- the bindings are for the right class
446 (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
448 extendTyVarEnvForMethodBinds inst_tyvars (
449 -- (Slightly strangely) the forall-d tyvars scope over
450 -- the method bindings too
451 rnMethodBinds cls (\_ -> []) -- No scoped tyvars
453 ) `thenM` \ (mbinds', meth_fvs) ->
454 -- Rename the associated types
455 -- The typechecker (not the renamer) checks that all
456 -- the declarations are for the right class
458 at_names = map (head . hsTyClDeclBinders) ats
460 checkDupRdrNames at_names `thenM_`
461 -- See notes with checkDupRdrNames for methods, above
463 rnATInsts ats `thenM` \ (ats', at_fvs) ->
465 -- Rename the prags and signatures.
466 -- Note that the type variables are not in scope here,
467 -- so that instance Eq a => Eq (T a) where
468 -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
471 -- But the (unqualified) method names are in scope
473 binders = collectHsBindsBinders mbinds'
474 bndr_set = mkNameSet binders
476 bindLocalNames binders
477 (renameSigs (Just bndr_set) okInstDclSig uprags) `thenM` \ uprags' ->
479 return (InstDecl inst_ty' mbinds' uprags' ats',
480 meth_fvs `plusFV` at_fvs
481 `plusFV` hsSigsFVs uprags'
482 `plusFV` extractHsTyNames inst_ty')
483 -- We return the renamed associated data type declarations so
484 -- that they can be entered into the list of type declarations
485 -- for the binding group, but we also keep a copy in the instance.
486 -- The latter is needed for well-formedness checks in the type
487 -- checker (eg, to ensure that all ATs of the instance actually
488 -- receive a declaration).
489 -- NB: Even the copies in the instance declaration carry copies of
490 -- the instance context after renaming. This is a bit
491 -- strange, but should not matter (and it would be more work
492 -- to remove the context).
495 Renaming of the associated types in instances.
498 rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
499 rnATInsts atDecls = rnList rnATInst atDecls
501 rnATInst tydecl@TyData {} = rnTyClDecl tydecl
502 rnATInst tydecl@TySynonym {} = rnTyClDecl tydecl
504 pprPanic "RnSource.rnATInsts: invalid AT instance"
505 (ppr (tcdName tydecl))
508 For the method bindings in class and instance decls, we extend the
509 type variable environment iff -fglasgow-exts
512 extendTyVarEnvForMethodBinds :: [LHsTyVarBndr Name]
513 -> RnM (Bag (LHsBind Name), FreeVars)
514 -> RnM (Bag (LHsBind Name), FreeVars)
515 extendTyVarEnvForMethodBinds tyvars thing_inside
516 = do { scoped_tvs <- xoptM Opt_ScopedTypeVariables
518 extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
523 %*********************************************************
525 \subsection{Stand-alone deriving declarations}
527 %*********************************************************
530 rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
531 rnSrcDerivDecl (DerivDecl ty)
532 = do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving
533 ; unless standalone_deriv_ok (addErr standaloneDerivErr)
534 ; ty' <- rnLHsType (text "a deriving decl") ty
535 ; let fvs = extractHsTyNames ty'
536 ; return (DerivDecl ty', fvs) }
538 standaloneDerivErr :: SDoc
540 = hang (ptext (sLit "Illegal standalone deriving declaration"))
541 2 (ptext (sLit "Use -XStandaloneDeriving to enable this extension"))
544 %*********************************************************
548 %*********************************************************
551 rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
552 rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
553 = bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $
554 bindLocatedLocalsFV (map get_var vars) $ \ ids ->
555 do { (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids)
556 -- NB: The binders in a rule are always Ids
557 -- We don't (yet) support type variables
559 ; (lhs', fv_lhs') <- rnLExpr lhs
560 ; (rhs', fv_rhs') <- rnLExpr rhs
562 ; checkValidRule rule_name ids lhs' fv_lhs'
564 ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
565 fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') }
567 doc = text "In the transformation rule" <+> ftext rule_name
569 get_var (RuleBndr v) = v
570 get_var (RuleBndrSig v _) = v
572 rn_var (RuleBndr (L loc _), id)
573 = return (RuleBndr (L loc id), emptyFVs)
574 rn_var (RuleBndrSig (L loc _) t, id)
575 = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
576 return (RuleBndrSig (L loc id) t', fvs)
578 badRuleVar :: FastString -> Name -> SDoc
580 = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon,
581 ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+>
582 ptext (sLit "does not appear on left hand side")]
585 Note [Rule LHS validity checking]
586 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
587 Check the shape of a transformation rule LHS. Currently we only allow
588 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
589 @forall@'d variables.
591 We used restrict the form of the 'ei' to prevent you writing rules
592 with LHSs with a complicated desugaring (and hence unlikely to match);
593 (e.g. a case expression is not allowed: too elaborate.)
595 But there are legitimate non-trivial args ei, like sections and
596 lambdas. So it seems simmpler not to check at all, and that is why
597 check_e is commented out.
600 checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM ()
601 checkValidRule rule_name ids lhs' fv_lhs'
602 = do { -- Check for the form of the LHS
603 case (validRuleLhs ids lhs') of
605 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
607 -- Check that LHS vars are all bound
608 ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
609 ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
611 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
613 -- Just e => Not ok, and e is the offending expression
614 validRuleLhs foralls lhs
617 checkl (L _ e) = check e
619 check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
620 check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2
621 check (HsVar v) | v `notElem` foralls = Nothing
622 check other = Just other -- Failure
625 checkl_e (L _ _e) = Nothing -- Was (check_e e); see Note [Rule LHS validity checking]
627 {- Commented out; see Note [Rule LHS validity checking] above
628 check_e (HsVar v) = Nothing
629 check_e (HsPar e) = checkl_e e
630 check_e (HsLit e) = Nothing
631 check_e (HsOverLit e) = Nothing
633 check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
634 check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2
635 check_e (NegApp e _) = checkl_e e
636 check_e (ExplicitList _ es) = checkl_es es
637 check_e other = Just other -- Fails
639 checkl_es es = foldr (mplus . checkl_e) Nothing es
642 badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
643 badRuleLhsErr name lhs bad_e
644 = sep [ptext (sLit "Rule") <+> ftext name <> colon,
645 nest 4 (vcat [ptext (sLit "Illegal expression:") <+> ppr bad_e,
646 ptext (sLit "in left-hand side:") <+> ppr lhs])]
648 ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd")
652 %*********************************************************
654 \subsection{Vectorisation declarations}
656 %*********************************************************
659 rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars)
660 rnHsVectDecl (HsVect var Nothing)
661 = do { var' <- wrapLocM lookupTopBndrRn var
662 ; return (HsVect var' Nothing, unitFV (unLoc var'))
664 rnHsVectDecl (HsVect var (Just rhs))
665 = do { var' <- wrapLocM lookupTopBndrRn var
666 ; (rhs', fv_rhs) <- rnLExpr rhs
667 ; return (HsVect var' (Just rhs'), fv_rhs `addOneFV` unLoc var')
671 %*********************************************************
673 \subsection{Type, class and iface sig declarations}
675 %*********************************************************
677 @rnTyDecl@ uses the `global name function' to create a new type
678 declaration in which local names have been replaced by their original
679 names, reporting any unknown names.
681 Renaming type variables is a pain. Because they now contain uniques,
682 it is necessary to pass in an association list which maps a parsed
683 tyvar to its @Name@ representation.
684 In some cases (type signatures of values),
685 it is even necessary to go over the type first
686 in order to get the set of tyvars used by it, make an assoc list,
687 and then go over it again to rename the tyvars!
688 However, we can also do some scoping checks at the same time.
691 rnTyClDecls :: [[LTyClDecl RdrName]] -> RnM ([[LTyClDecl Name]], FreeVars)
692 -- Renamed the declarations and do depedency analysis on them
694 = do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (concat tycl_ds)
696 ; let sccs :: [SCC (LTyClDecl Name)]
697 sccs = depAnalTyClDecls ds_w_fvs
699 all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs
701 ; return (map flattenSCC sccs, all_fvs) }
703 rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars)
704 rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name})
705 = lookupLocatedTopBndrRn name `thenM` \ name' ->
706 return (ForeignType {tcdLName = name', tcdExtName = ext_name},
709 -- all flavours of type family declarations ("type family", "newtype fanily",
710 -- and "data family")
711 rnTyClDecl tydecl@TyFamily {} = rnFamily tydecl bindTyVarsFV
713 -- "data", "newtype", "data instance, and "newtype instance" declarations
714 rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
715 tcdLName = tycon, tcdTyVars = tyvars,
716 tcdTyPats = typats, tcdCons = condecls,
717 tcdKindSig = sig, tcdDerivs = derivs}
718 = do { tycon' <- if isFamInstDecl tydecl
719 then lookupLocatedOccRn tycon -- may be imported family
720 else lookupLocatedTopBndrRn tycon
721 ; checkTc (h98_style || null (unLoc context))
722 (badGadtStupidTheta tycon)
723 ; ((tyvars', context', typats', derivs'), stuff_fvs)
724 <- bindTyVarsFV tyvars $ \ tyvars' -> do
725 -- Checks for distinct tyvars
726 { context' <- rnContext data_doc context
727 ; (typats', fvs1) <- rnTyPats data_doc tycon' typats
728 ; (derivs', fvs2) <- rn_derivs derivs
729 ; let fvs = fvs1 `plusFV` fvs2 `plusFV`
730 extractHsCtxtTyNames context'
731 ; return ((tyvars', context', typats', derivs'), fvs) }
733 -- For the constructor declarations, bring into scope the tyvars
734 -- bound by the header, but *only* in the H98 case
735 -- Reason: for GADTs, the type variables in the declaration
736 -- do not scope over the constructor signatures
737 -- data T a where { T1 :: forall b. b-> b }
738 ; let tc_tvs_in_scope | h98_style = hsLTyVarNames tyvars'
740 ; (condecls', con_fvs) <- bindLocalNamesFV tc_tvs_in_scope $
742 -- No need to check for duplicate constructor decls
743 -- since that is done by RnNames.extendGlobalRdrEnvRn
745 ; return (TyData {tcdND = new_or_data, tcdCtxt = context',
746 tcdLName = tycon', tcdTyVars = tyvars',
747 tcdTyPats = typats', tcdKindSig = sig,
748 tcdCons = condecls', tcdDerivs = derivs'},
749 con_fvs `plusFV` stuff_fvs)
752 h98_style = case condecls of -- Note [Stupid theta]
753 L _ (ConDecl { con_res = ResTyGADT {} }) : _ -> False
756 data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
758 rn_derivs Nothing = return (Nothing, emptyFVs)
759 rn_derivs (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' ->
760 return (Just ds', extractHsTyNames_s ds')
762 -- "type" and "type instance" declarations
763 rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
764 tcdTyPats = typats, tcdSynRhs = ty})
765 = bindTyVarsFV tyvars $ \ tyvars' -> do
766 { -- Checks for distinct tyvars
767 name' <- if isFamInstDecl tydecl
768 then lookupLocatedOccRn name -- may be imported family
769 else lookupLocatedTopBndrRn name
770 ; (typats',fvs1) <- rnTyPats syn_doc name' typats
771 ; (ty', fvs2) <- rnHsTypeFVs syn_doc ty
772 ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars'
773 , tcdTyPats = typats', tcdSynRhs = ty'},
774 fvs1 `plusFV` fvs2) }
776 syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
778 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
779 tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
780 tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
781 = do { cname' <- lookupLocatedTopBndrRn cname
783 -- Tyvars scope over superclass context and method signatures
784 ; ((tyvars', context', fds', ats', sigs'), stuff_fvs)
785 <- bindTyVarsFV tyvars $ \ tyvars' -> do
786 -- Checks for distinct tyvars
787 { context' <- rnContext cls_doc context
788 ; fds' <- rnFds cls_doc fds
789 ; (ats', at_fvs) <- rnATs ats
790 ; sigs' <- renameSigs Nothing okClsDclSig sigs
791 ; let fvs = at_fvs `plusFV`
792 extractHsCtxtTyNames context' `plusFV`
794 -- The fundeps have no free variables
795 ; return ((tyvars', context', fds', ats', sigs'), fvs) }
797 -- No need to check for duplicate associated type decls
798 -- since that is done by RnNames.extendGlobalRdrEnvRn
800 -- Check the signatures
801 -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
802 ; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
803 ; checkDupRdrNames sig_rdr_names_w_locs
804 -- Typechecker is responsible for checking that we only
805 -- give default-method bindings for things in this class.
806 -- The renamer *could* check this for class decls, but can't
807 -- for instance decls.
809 -- The newLocals call is tiresome: given a generic class decl
812 -- op {| x+y |} (Inl a) = ...
813 -- op {| x+y |} (Inr b) = ...
814 -- op {| a*b |} (a*b) = ...
815 -- we want to name both "x" tyvars with the same unique, so that they are
816 -- easy to group together in the typechecker.
817 ; (mbinds', meth_fvs)
818 <- extendTyVarEnvForMethodBinds tyvars' $
819 -- No need to check for duplicate method signatures
820 -- since that is done by RnNames.extendGlobalRdrEnvRn
821 -- and the methods are already in scope
822 rnMethodBinds (unLoc cname') (mkSigTvFn sigs') mbinds
825 ; docs' <- mapM (wrapLocM rnDocDecl) docs
827 ; return (ClassDecl { tcdCtxt = context', tcdLName = cname',
828 tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
829 tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
830 meth_fvs `plusFV` stuff_fvs) }
832 cls_doc = text "In the declaration for class" <+> ppr cname
834 badGadtStupidTheta :: Located RdrName -> SDoc
836 = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
837 ptext (sLit "(You can put a context on each contructor, though.)")]
842 Trac #3850 complains about a regression wrt 6.10 for
844 There is no reason not to allow the stupid theta if there are no data
845 constructors. It's still stupid, but does no harm, and I don't want
846 to cause programs to break unnecessarily (notably HList). So if there
847 are no data constructors we allow h98_style = True
851 depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)]
852 -- See Note [Dependency analysis of type and class decls]
853 depAnalTyClDecls ds_w_fvs
854 = stronglyConnCompFromEdgedVertices edges
856 edges = [ (d, tcdName (unLoc d), map get_assoc (nameSetToList fvs))
857 | (d, fvs) <- ds_w_fvs ]
858 get_assoc n = lookupNameEnv assoc_env n `orElse` n
859 assoc_env = mkNameEnv [ (tcdName assoc_decl, cls_name)
860 | (L _ (ClassDecl { tcdLName = L _ cls_name
861 , tcdATs = ats }) ,_) <- ds_w_fvs
862 , L _ assoc_decl <- ats ]
865 Note [Dependency analysis of type and class decls]
866 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
867 We need to do dependency analysis on type and class declarations
868 else we get bad error messages. Consider
871 data S f a = MkS f (T f a)
873 This has a kind error, but the error message is better if you
874 check T first, (fixing its kind) and *then* S. If you do kind
875 inference together, you might get an error reported in S, which
876 is jolly confusing. See Trac #4875
879 %*********************************************************
881 \subsection{Support code for type/data declarations}
883 %*********************************************************
886 rnTyPats :: SDoc -> Located Name -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name], FreeVars)
887 -- Although, we are processing type patterns here, all type variables will
888 -- already be in scope (they are the same as in the 'tcdTyVars' field of the
889 -- type declaration to which these patterns belong)
891 = return (Nothing, emptyFVs)
892 rnTyPats doc tc (Just typats)
893 = do { typats' <- rnLHsTypes doc typats
894 ; let fvs = addOneFV (extractHsTyNames_s typats') (unLoc tc)
895 -- type instance => use, hence addOneFV
896 ; return (Just typats', fvs) }
898 rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
900 = do { condecls' <- mapM (wrapLocM rnConDecl) condecls
901 ; return (condecls', plusFVs (map conDeclFVs condecls')) }
903 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
904 rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
905 , con_cxt = cxt, con_details = details
906 , con_res = res_ty, con_doc = mb_doc
907 , con_old_rec = old_rec, con_explicit = expl })
908 = do { addLocM checkConName name
909 ; when old_rec (addWarn (deprecRecSyntax decl))
910 ; new_name <- lookupLocatedTopBndrRn name
912 -- For H98 syntax, the tvs are the existential ones
913 -- For GADT syntax, the tvs are all the quantified tyvars
914 -- Hence the 'filter' in the ResTyH98 case only
915 ; rdr_env <- getLocalRdrEnv
916 ; let in_scope = (`elemLocalRdrEnv` rdr_env) . unLoc
917 arg_tys = hsConDeclArgTys details
918 implicit_tvs = case res_ty of
919 ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys)
920 ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
921 new_tvs = case expl of
923 Implicit -> userHsTyVarBndrs implicit_tvs
925 ; mb_doc' <- rnMbLHsDoc mb_doc
927 ; bindTyVarsRn new_tvs $ \new_tyvars -> do
928 { new_context <- rnContext doc cxt
929 ; new_details <- rnConDeclDetails doc details
930 ; (new_details', new_res_ty) <- rnConResult doc new_details res_ty
931 ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context
932 , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }}
934 doc = text "In the definition of data constructor" <+> quotes (ppr name)
935 get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
938 -> HsConDetails (LHsType Name) [ConDeclField Name]
940 -> RnM (HsConDetails (LHsType Name) [ConDeclField Name],
942 rnConResult _ details ResTyH98 = return (details, ResTyH98)
943 rnConResult doc details (ResTyGADT ty)
944 = do { ty' <- rnLHsType doc ty
945 ; let (arg_tys, res_ty) = splitHsFunType ty'
946 -- We can finally split it up,
947 -- now the renamer has dealt with fixities
948 -- See Note [Sorting out the result type] in RdrHsSyn
950 details' = case details of
952 PrefixCon {} -> PrefixCon arg_tys
953 InfixCon {} -> pprPanic "rnConResult" (ppr ty)
954 -- See Note [Sorting out the result type] in RdrHsSyn
956 ; when (not (null arg_tys) && case details of { RecCon {} -> True; _ -> False })
957 (addErr (badRecResTy doc))
958 ; return (details', ResTyGADT res_ty) }
960 rnConDeclDetails :: SDoc
961 -> HsConDetails (LHsType RdrName) [ConDeclField RdrName]
962 -> RnM (HsConDetails (LHsType Name) [ConDeclField Name])
963 rnConDeclDetails doc (PrefixCon tys)
964 = mapM (rnLHsType doc) tys `thenM` \ new_tys ->
965 return (PrefixCon new_tys)
967 rnConDeclDetails doc (InfixCon ty1 ty2)
968 = rnLHsType doc ty1 `thenM` \ new_ty1 ->
969 rnLHsType doc ty2 `thenM` \ new_ty2 ->
970 return (InfixCon new_ty1 new_ty2)
972 rnConDeclDetails doc (RecCon fields)
973 = do { new_fields <- rnConDeclFields doc fields
974 -- No need to check for duplicate fields
975 -- since that is done by RnNames.extendGlobalRdrEnvRn
976 ; return (RecCon new_fields) }
978 -- Rename family declarations
980 -- * This function is parametrised by the routine handling the index
981 -- variables. On the toplevel, these are defining occurences, whereas they
982 -- are usage occurences for associated types.
984 rnFamily :: TyClDecl RdrName
985 -> ([LHsTyVarBndr RdrName] ->
986 ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
987 RnM (TyClDecl Name, FreeVars))
988 -> RnM (TyClDecl Name, FreeVars)
990 rnFamily (tydecl@TyFamily {tcdFlavour = flavour,
991 tcdLName = tycon, tcdTyVars = tyvars})
993 do { bindIdxVars tyvars $ \tyvars' -> do {
994 ; tycon' <- lookupLocatedTopBndrRn tycon
995 ; return (TyFamily {tcdFlavour = flavour, tcdLName = tycon',
996 tcdTyVars = tyvars', tcdKind = tcdKind tydecl},
999 rnFamily d _ = pprPanic "rnFamily" (ppr d)
1001 -- Rename associated type declarations (in classes)
1003 -- * This can be family declarations and (default) type instances
1005 rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
1006 rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
1008 rn_at (tydecl@TyFamily {}) = rnFamily tydecl lookupIdxVars
1009 rn_at (tydecl@TySynonym {}) =
1011 unless (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
1013 rn_at _ = panic "RnSource.rnATs: invalid TyClDecl"
1015 lookupIdxVars tyvars cont =
1016 do { checkForDups tyvars
1017 ; tyvars' <- mapM lookupIdxVar tyvars
1020 -- Type index variables must be class parameters, which are the only
1021 -- type variables in scope at this point.
1022 lookupIdxVar (L l tyvar) =
1024 name' <- lookupOccRn (hsTyVarName tyvar)
1025 return $ L l (replaceTyVarName tyvar name')
1027 -- Type variable may only occur once.
1029 checkForDups [] = return ()
1030 checkForDups (L loc tv:ltvs) =
1031 do { setSrcSpan loc $
1032 when (hsTyVarName tv `ltvElem` ltvs) $
1033 addErr (repeatedTyVar tv)
1037 _ `ltvElem` [] = False
1038 rdrName `ltvElem` (L _ tv:ltvs)
1039 | rdrName == hsTyVarName tv = True
1040 | otherwise = rdrName `ltvElem` ltvs
1042 deprecRecSyntax :: ConDecl RdrName -> SDoc
1043 deprecRecSyntax decl
1044 = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_name decl))
1045 <+> ptext (sLit "uses deprecated syntax")
1046 , ptext (sLit "Instead, use the form")
1047 , nest 2 (ppr decl) ] -- Pretty printer uses new form
1049 badRecResTy :: SDoc -> SDoc
1050 badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
1053 noPatterns = text "Default definition for an associated synonym cannot have"
1054 <+> text "type pattern"
1056 repeatedTyVar :: HsTyVarBndr RdrName -> SDoc
1057 repeatedTyVar tv = ptext (sLit "Illegal repeated type variable") <+>
1060 -- This data decl will parse OK
1062 -- treating "a" as the constructor.
1063 -- It is really hard to make the parser spot this malformation.
1064 -- So the renamer has to check that the constructor is legal
1066 -- We can get an operator as the constructor, even in the prefix form:
1067 -- data T = :% Int Int
1068 -- from interface files, which always print in prefix form
1070 checkConName :: RdrName -> TcRn ()
1071 checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
1073 badDataCon :: RdrName -> SDoc
1075 = hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)]
1079 %*********************************************************
1081 \subsection{Support code for type/data declarations}
1083 %*********************************************************
1085 Get the mapping from constructors to fields for this module.
1086 It's convenient to do this after the data type decls have been renamed
1088 extendRecordFieldEnv :: [[LTyClDecl RdrName]] -> [LInstDecl RdrName] -> TcM TcGblEnv
1089 extendRecordFieldEnv tycl_decls inst_decls
1090 = do { tcg_env <- getGblEnv
1091 ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
1092 ; return (tcg_env { tcg_field_env = field_env' }) }
1094 -- we want to lookup:
1095 -- (a) a datatype constructor
1096 -- (b) a record field
1097 -- knowing that they're from this module.
1098 -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn,
1099 -- which keeps only the local ones.
1100 lookup x = do { x' <- lookupLocatedTopBndrRn x
1101 ; return $ unLoc x'}
1103 all_data_cons :: [ConDecl RdrName]
1104 all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls
1106 all_tycl_decls = at_tycl_decls ++ concat tycl_decls
1107 at_tycl_decls = instDeclATs inst_decls -- Do not forget associated types!
1109 get_con (ConDecl { con_name = con, con_details = RecCon flds })
1110 (RecFields env fld_set)
1111 = do { con' <- lookup con
1112 ; flds' <- mapM lookup (map cd_fld_name flds)
1113 ; let env' = extendNameEnv env con' flds'
1114 fld_set' = addListToNameSet fld_set flds'
1115 ; return $ (RecFields env' fld_set') }
1116 get_con _ env = return env
1119 %*********************************************************
1121 \subsection{Support code to rename types}
1123 %*********************************************************
1126 rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
1129 = mapM (wrapLocM rn_fds) fds
1132 = rnHsTyVars doc tys1 `thenM` \ tys1' ->
1133 rnHsTyVars doc tys2 `thenM` \ tys2' ->
1134 return (tys1', tys2')
1136 rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name]
1137 rnHsTyVars doc tvs = mapM (rnHsTyVar doc) tvs
1139 rnHsTyVar :: SDoc -> RdrName -> RnM Name
1140 rnHsTyVar _doc tyvar = lookupOccRn tyvar
1144 %*********************************************************
1148 %*********************************************************
1150 This code marches down the declarations, looking for the first
1151 Template Haskell splice. As it does so it
1152 a) groups the declarations into a HsGroup
1153 b) runs any top-level quasi-quotes
1156 findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1157 findSplice ds = addl emptyRdrGroup ds
1159 addl :: HsGroup RdrName -> [LHsDecl RdrName]
1160 -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1161 -- This stuff reverses the declarations (again) but it doesn't matter
1162 addl gp [] = return (gp, Nothing)
1163 addl gp (L l d : ds) = add gp l d ds
1166 add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName]
1167 -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1169 add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
1170 = do { -- We've found a top-level splice. If it is an *implicit* one
1171 -- (i.e. a naked top level expression)
1173 Explicit -> return ()
1174 Implicit -> do { th_on <- xoptM Opt_TemplateHaskell
1175 ; unless th_on $ setSrcSpan loc $
1176 failWith badImplicitSplice }
1178 ; return (gp, Just (splice, ds)) }
1180 badImplicitSplice = ptext (sLit "Parse error: naked expression at top level")
1183 add _ _ (QuasiQuoteD qq) _
1184 = pprPanic "Can't do QuasiQuote declarations without GHCi" (ppr qq)
1186 add gp _ (QuasiQuoteD qq) ds -- Expand quasiquotes
1187 = do { ds' <- runQuasiQuoteDecl qq
1188 ; addl gp (ds' ++ ds) }
1191 -- Class declarations: pull out the fixity signatures to the top
1192 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
1194 = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
1195 addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
1197 = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
1199 -- Signatures: fixity sigs go a different place than all others
1200 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
1201 = addl (gp {hs_fixds = L l f : ts}) ds
1202 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
1203 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
1205 -- Value declarations: use add_bind
1206 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
1207 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
1209 -- The rest are routine
1210 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
1211 = addl (gp { hs_instds = L l d : ts }) ds
1212 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
1213 = addl (gp { hs_derivds = L l d : ts }) ds
1214 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
1215 = addl (gp { hs_defds = L l d : ts }) ds
1216 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
1217 = addl (gp { hs_fords = L l d : ts }) ds
1218 add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
1219 = addl (gp { hs_warnds = L l d : ts }) ds
1220 add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
1221 = addl (gp { hs_annds = L l d : ts }) ds
1222 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
1223 = addl (gp { hs_ruleds = L l d : ts }) ds
1224 add gp@(HsGroup {hs_vects = ts}) l (VectD d) ds
1225 = addl (gp { hs_vects = L l d : ts }) ds
1226 add gp l (DocD d) ds
1227 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
1229 add_tycld :: LTyClDecl a -> [[LTyClDecl a]] -> [[LTyClDecl a]]
1230 add_tycld d [] = [[d]]
1231 add_tycld d (ds:dss) = (d:ds) : dss
1233 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
1234 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
1235 add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
1237 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
1238 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
1239 add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"