Make use of boot TyThings during typechecking.
[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 {-# LANGUAGE FlexibleContexts #-}
9 {-# LANGUAGE TypeFamilies #-}
10
11 module RnSource (
12 rnSrcDecls, addTcgDUs, findSplice
13 ) where
14
15 #include "HsVersions.h"
16
17 import GhcPrelude
18
19 import {-# SOURCE #-} RnExpr( rnLExpr )
20 import {-# SOURCE #-} RnSplice ( rnSpliceDecl, rnTopSpliceDecls )
21
22 import HsSyn
23 import FieldLabel
24 import RdrName
25 import RnTypes
26 import RnBinds
27 import RnEnv
28 import RnUtils ( HsDocContext(..), mapFvRn, bindLocalNames
29 , checkDupRdrNames, inHsDocContext, bindLocalNamesFV
30 , checkShadowedRdrNames, warnUnusedTypePatterns
31 , extendTyVarEnvFVRn, newLocalBndrsRn )
32 import RnUnbound ( mkUnboundName )
33 import RnNames
34 import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
35 import TcAnnotations ( annCtxt )
36 import TcRnMonad
37
38 import ForeignCall ( CCallTarget(..) )
39 import Module
40 import HscTypes ( Warnings(..), plusWarns )
41 import Class ( FunDep )
42 import PrelNames ( applicativeClassName, pureAName, thenAName
43 , monadClassName, returnMName, thenMName
44 , monadFailClassName, failMName, failMName_preMFP
45 , semigroupClassName, sappendName
46 , monoidClassName, mappendName
47 )
48 import Name
49 import NameSet
50 import NameEnv
51 import Avail
52 import Outputable
53 import Bag
54 import BasicTypes ( DerivStrategy, RuleName, pprRuleName )
55 import Maybes ( orElse )
56 import FastString
57 import SrcLoc
58 import DynFlags
59 import Util ( debugIsOn, filterOut, lengthExceeds, partitionWith )
60 import HscTypes ( HscEnv, hsc_dflags )
61 import ListSetOps ( findDupsEq, removeDups, equivClasses )
62 import Digraph ( SCC, flattenSCC, flattenSCCs, Node(..)
63 , stronglyConnCompFromEdgedVerticesUniq )
64 import UniqSet
65 import qualified GHC.LanguageExtensions as LangExt
66
67 import Control.Monad
68 import Control.Arrow ( first )
69 import Data.List ( mapAccumL )
70 import qualified Data.List.NonEmpty as NE
71 import Data.List.NonEmpty ( NonEmpty(..) )
72 import Data.Maybe ( isJust )
73 import qualified Data.Set as Set ( difference, fromList, toList, null )
74
75 {- | @rnSourceDecl@ "renames" declarations.
76 It simultaneously performs dependency analysis and precedence parsing.
77 It also does the following error checks:
78
79 * Checks that tyvars are used properly. This includes checking
80 for undefined tyvars, and tyvars in contexts that are ambiguous.
81 (Some of this checking has now been moved to module @TcMonoType@,
82 since we don't have functional dependency information at this point.)
83
84 * Checks that all variable occurrences are defined.
85
86 * Checks the @(..)@ etc constraints in the export list.
87
88 Brings the binders of the group into scope in the appropriate places;
89 does NOT assume that anything is in scope already
90 -}
91 rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn)
92 -- Rename a top-level HsGroup; used for normal source files *and* hs-boot files
93 rnSrcDecls group@(HsGroup { hs_valds = val_decls,
94 hs_splcds = splice_decls,
95 hs_tyclds = tycl_decls,
96 hs_derivds = deriv_decls,
97 hs_fixds = fix_decls,
98 hs_warnds = warn_decls,
99 hs_annds = ann_decls,
100 hs_fords = foreign_decls,
101 hs_defds = default_decls,
102 hs_ruleds = rule_decls,
103 hs_vects = vect_decls,
104 hs_docs = docs })
105 = do {
106 -- (A) Process the fixity declarations, creating a mapping from
107 -- FastStrings to FixItems.
108 -- Also checks for duplicates.
109 local_fix_env <- makeMiniFixityEnv fix_decls ;
110
111 -- (B) Bring top level binders (and their fixities) into scope,
112 -- *except* for the value bindings, which get done in step (D)
113 -- with collectHsIdBinders. However *do* include
114 --
115 -- * Class ops, data constructors, and record fields,
116 -- because they do not have value declarations.
117 -- Aso step (C) depends on datacons and record fields
118 --
119 -- * For hs-boot files, include the value signatures
120 -- Again, they have no value declarations
121 --
122 (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;
123
124
125 setEnvs tc_envs $ do {
126
127 failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
128
129 -- (D1) Bring pattern synonyms into scope.
130 -- Need to do this before (D2) because rnTopBindsLHS
131 -- looks up those pattern synonyms (Trac #9889)
132
133 extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do {
134
135 -- (D2) Rename the left-hand sides of the value bindings.
136 -- This depends on everything from (B) being in scope,
137 -- and on (C) for resolving record wild cards.
138 -- It uses the fixity env from (A) to bind fixities for view patterns.
139 new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
140
141 -- Bind the LHSes (and their fixities) in the global rdr environment
142 let { id_bndrs = collectHsIdBinders new_lhs } ; -- Excludes pattern-synonym binders
143 -- They are already in scope
144 traceRn "rnSrcDecls" (ppr id_bndrs) ;
145 tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;
146 setEnvs tc_envs $ do {
147
148 -- Now everything is in scope, as the remaining renaming assumes.
149
150 -- (E) Rename type and class decls
151 -- (note that value LHSes need to be in scope for default methods)
152 --
153 -- You might think that we could build proper def/use information
154 -- for type and class declarations, but they can be involved
155 -- in mutual recursion across modules, and we only do the SCC
156 -- analysis for them in the type checker.
157 -- So we content ourselves with gathering uses only; that
158 -- means we'll only report a declaration as unused if it isn't
159 -- mentioned at all. Ah well.
160 traceRn "Start rnTyClDecls" (ppr tycl_decls) ;
161 (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
162
163 -- (F) Rename Value declarations right-hand sides
164 traceRn "Start rnmono" empty ;
165 let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;
166 is_boot <- tcIsHsBootOrSig ;
167 (rn_val_decls, bind_dus) <- if is_boot
168 -- For an hs-boot, use tc_bndrs (which collects how we're renamed
169 -- signatures), since val_bndr_set is empty (there are no x = ...
170 -- bindings in an hs-boot.)
171 then rnTopBindsBoot tc_bndrs new_lhs
172 else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ;
173 traceRn "finish rnmono" (ppr rn_val_decls) ;
174
175 -- (G) Rename Fixity and deprecations
176
177 -- Rename fixity declarations and error if we try to
178 -- fix something from another module (duplicates were checked in (A))
179 let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ;
180 rn_fix_decls <- mapM (mapM (rnSrcFixityDecl (TopSigCtxt all_bndrs)))
181 fix_decls ;
182
183 -- Rename deprec decls;
184 -- check for duplicates and ensure that deprecated things are defined locally
185 -- at the moment, we don't keep these around past renaming
186 rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ;
187
188 -- (H) Rename Everything else
189
190 (rn_rule_decls, src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $
191 rnList rnHsRuleDecls rule_decls ;
192 -- Inside RULES, scoped type variables are on
193 (rn_vect_decls, src_fvs3) <- rnList rnHsVectDecl vect_decls ;
194 (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
195 (rn_ann_decls, src_fvs5) <- rnList rnAnnDecl ann_decls ;
196 (rn_default_decls, src_fvs6) <- rnList rnDefaultDecl default_decls ;
197 (rn_deriv_decls, src_fvs7) <- rnList rnSrcDerivDecl deriv_decls ;
198 (rn_splice_decls, src_fvs8) <- rnList rnSpliceDecl splice_decls ;
199 -- Haddock docs; no free vars
200 rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
201
202 last_tcg_env <- getGblEnv ;
203 -- (I) Compute the results and return
204 let {rn_group = HsGroup { hs_valds = rn_val_decls,
205 hs_splcds = rn_splice_decls,
206 hs_tyclds = rn_tycl_decls,
207 hs_derivds = rn_deriv_decls,
208 hs_fixds = rn_fix_decls,
209 hs_warnds = [], -- warns are returned in the tcg_env
210 -- (see below) not in the HsGroup
211 hs_fords = rn_foreign_decls,
212 hs_annds = rn_ann_decls,
213 hs_defds = rn_default_decls,
214 hs_ruleds = rn_rule_decls,
215 hs_vects = rn_vect_decls,
216 hs_docs = rn_docs } ;
217
218 tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ;
219 other_def = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;
220 other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, src_fvs5,
221 src_fvs6, src_fvs7, src_fvs8] ;
222 -- It is tiresome to gather the binders from type and class decls
223
224 src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
225 -- Instance decls may have occurrences of things bound in bind_dus
226 -- so we must put other_fvs last
227
228 final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus)
229 in -- we return the deprecs in the env, not in the HsGroup above
230 tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
231 } ;
232 traceRn "finish rnSrc" (ppr rn_group) ;
233 traceRn "finish Dus" (ppr src_dus ) ;
234 return (final_tcg_env, rn_group)
235 }}}}
236
237 addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
238 -- This function could be defined lower down in the module hierarchy,
239 -- but there doesn't seem anywhere very logical to put it.
240 addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
241
242 rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
243 rnList f xs = mapFvRn (wrapLocFstM f) xs
244
245 {-
246 *********************************************************
247 * *
248 HsDoc stuff
249 * *
250 *********************************************************
251 -}
252
253 rnDocDecl :: DocDecl -> RnM DocDecl
254 rnDocDecl (DocCommentNext doc) = do
255 rn_doc <- rnHsDoc doc
256 return (DocCommentNext rn_doc)
257 rnDocDecl (DocCommentPrev doc) = do
258 rn_doc <- rnHsDoc doc
259 return (DocCommentPrev rn_doc)
260 rnDocDecl (DocCommentNamed str doc) = do
261 rn_doc <- rnHsDoc doc
262 return (DocCommentNamed str rn_doc)
263 rnDocDecl (DocGroup lev doc) = do
264 rn_doc <- rnHsDoc doc
265 return (DocGroup lev rn_doc)
266
267 {-
268 *********************************************************
269 * *
270 Source-code deprecations declarations
271 * *
272 *********************************************************
273
274 Check that the deprecated names are defined, are defined locally, and
275 that there are no duplicate deprecations.
276
277 It's only imported deprecations, dealt with in RnIfaces, that we
278 gather them together.
279 -}
280
281 -- checks that the deprecations are defined locally, and that there are no duplicates
282 rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings
283 rnSrcWarnDecls _ []
284 = return NoWarnings
285
286 rnSrcWarnDecls bndr_set decls'
287 = do { -- check for duplicates
288 ; mapM_ (\ dups -> let (L loc rdr :| (lrdr':_)) = dups
289 in addErrAt loc (dupWarnDecl lrdr' rdr))
290 warn_rdr_dups
291 ; pairs_s <- mapM (addLocM rn_deprec) decls
292 ; return (WarnSome ((concat pairs_s))) }
293 where
294 decls = concatMap (\(L _ d) -> wd_warnings d) decls'
295
296 sig_ctxt = TopSigCtxt bndr_set
297
298 rn_deprec (Warning rdr_names txt)
299 -- ensures that the names are defined locally
300 = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)
301 rdr_names
302 ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }
303
304 what = text "deprecation"
305
306 warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning ns _)) -> ns)
307 decls
308
309 findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)]
310 findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
311
312 -- look for duplicates among the OccNames;
313 -- we check that the names are defined above
314 -- invt: the lists returned by findDupsEq always have at least two elements
315
316 dupWarnDecl :: Located RdrName -> RdrName -> SDoc
317 -- Located RdrName -> DeprecDecl RdrName -> SDoc
318 dupWarnDecl (L loc _) rdr_name
319 = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),
320 text "also at " <+> ppr loc]
321
322 {-
323 *********************************************************
324 * *
325 \subsection{Annotation declarations}
326 * *
327 *********************************************************
328 -}
329
330 rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
331 rnAnnDecl ann@(HsAnnotation s provenance expr)
332 = addErrCtxt (annCtxt ann) $
333 do { (provenance', provenance_fvs) <- rnAnnProvenance provenance
334 ; (expr', expr_fvs) <- setStage (Splice Untyped) $
335 rnLExpr expr
336 ; return (HsAnnotation s provenance' expr',
337 provenance_fvs `plusFV` expr_fvs) }
338
339 rnAnnProvenance :: AnnProvenance RdrName
340 -> RnM (AnnProvenance Name, FreeVars)
341 rnAnnProvenance provenance = do
342 provenance' <- traverse lookupTopBndrRn provenance
343 return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))
344
345 {-
346 *********************************************************
347 * *
348 \subsection{Default declarations}
349 * *
350 *********************************************************
351 -}
352
353 rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)
354 rnDefaultDecl (DefaultDecl tys)
355 = do { (tys', fvs) <- rnLHsTypes doc_str tys
356 ; return (DefaultDecl tys', fvs) }
357 where
358 doc_str = DefaultDeclCtx
359
360 {-
361 *********************************************************
362 * *
363 \subsection{Foreign declarations}
364 * *
365 *********************************************************
366 -}
367
368 rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars)
369 rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })
370 = do { topEnv :: HscEnv <- getTopEnv
371 ; name' <- lookupLocatedTopBndrRn name
372 ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
373
374 -- Mark any PackageTarget style imports as coming from the current package
375 ; let unitId = thisPackage $ hsc_dflags topEnv
376 spec' = patchForeignImport unitId spec
377
378 ; return (ForeignImport { fd_name = name', fd_sig_ty = ty'
379 , fd_co = noForeignImportCoercionYet
380 , fd_fi = spec' }, fvs) }
381
382 rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })
383 = do { name' <- lookupLocatedOccRn name
384 ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
385 ; return (ForeignExport { fd_name = name', fd_sig_ty = ty'
386 , fd_co = noForeignExportCoercionYet
387 , fd_fe = spec }
388 , fvs `addOneFV` unLoc name') }
389 -- NB: a foreign export is an *occurrence site* for name, so
390 -- we add it to the free-variable list. It might, for example,
391 -- be imported from another module
392
393 -- | For Windows DLLs we need to know what packages imported symbols are from
394 -- to generate correct calls. Imported symbols are tagged with the current
395 -- package, so if they get inlined across a package boundry we'll still
396 -- know where they're from.
397 --
398 patchForeignImport :: UnitId -> ForeignImport -> ForeignImport
399 patchForeignImport unitId (CImport cconv safety fs spec src)
400 = CImport cconv safety fs (patchCImportSpec unitId spec) src
401
402 patchCImportSpec :: UnitId -> CImportSpec -> CImportSpec
403 patchCImportSpec unitId spec
404 = case spec of
405 CFunction callTarget -> CFunction $ patchCCallTarget unitId callTarget
406 _ -> spec
407
408 patchCCallTarget :: UnitId -> CCallTarget -> CCallTarget
409 patchCCallTarget unitId callTarget =
410 case callTarget of
411 StaticTarget src label Nothing isFun
412 -> StaticTarget src label (Just unitId) isFun
413 _ -> callTarget
414
415 {-
416 *********************************************************
417 * *
418 \subsection{Instance declarations}
419 * *
420 *********************************************************
421 -}
422
423 rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)
424 rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })
425 = do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi
426 ; return (TyFamInstD { tfid_inst = tfi' }, fvs) }
427
428 rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })
429 = do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi
430 ; return (DataFamInstD { dfid_inst = dfi' }, fvs) }
431
432 rnSrcInstDecl (ClsInstD { cid_inst = cid })
433 = do { traceRn "rnSrcIstDecl {" (ppr cid)
434 ; (cid', fvs) <- rnClsInstDecl cid
435 ; traceRn "rnSrcIstDecl end }" empty
436 ; return (ClsInstD { cid_inst = cid' }, fvs) }
437
438 -- | Warn about non-canonical typeclass instance declarations
439 --
440 -- A "non-canonical" instance definition can occur for instances of a
441 -- class which redundantly defines an operation its superclass
442 -- provides as well (c.f. `return`/`pure`). In such cases, a canonical
443 -- instance is one where the subclass inherits its method
444 -- implementation from its superclass instance (usually the subclass
445 -- has a default method implementation to that effect). Consequently,
446 -- a non-canonical instance occurs when this is not the case.
447 --
448 -- See also descriptions of 'checkCanonicalMonadInstances' and
449 -- 'checkCanonicalMonoidInstances'
450 checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM ()
451 checkCanonicalInstances cls poly_ty mbinds = do
452 whenWOptM Opt_WarnNonCanonicalMonadInstances
453 checkCanonicalMonadInstances
454
455 whenWOptM Opt_WarnNonCanonicalMonadFailInstances
456 checkCanonicalMonadFailInstances
457
458 whenWOptM Opt_WarnNonCanonicalMonoidInstances
459 checkCanonicalMonoidInstances
460
461 where
462 -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance
463 -- declarations. Specifically, the following conditions are verified:
464 --
465 -- In 'Monad' instances declarations:
466 --
467 -- * If 'return' is overridden it must be canonical (i.e. @return = pure@)
468 -- * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@)
469 --
470 -- In 'Applicative' instance declarations:
471 --
472 -- * Warn if 'pure' is defined backwards (i.e. @pure = return@).
473 -- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@).
474 --
475 checkCanonicalMonadInstances
476 | cls == applicativeClassName = do
477 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
478 case mbind of
479 FunBind { fun_id = L _ name, fun_matches = mg }
480 | name == pureAName, isAliasMG mg == Just returnMName
481 -> addWarnNonCanonicalMethod1
482 Opt_WarnNonCanonicalMonadInstances "pure" "return"
483
484 | name == thenAName, isAliasMG mg == Just thenMName
485 -> addWarnNonCanonicalMethod1
486 Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)"
487
488 _ -> return ()
489
490 | cls == monadClassName = do
491 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
492 case mbind of
493 FunBind { fun_id = L _ name, fun_matches = mg }
494 | name == returnMName, isAliasMG mg /= Just pureAName
495 -> addWarnNonCanonicalMethod2
496 Opt_WarnNonCanonicalMonadInstances "return" "pure"
497
498 | name == thenMName, isAliasMG mg /= Just thenAName
499 -> addWarnNonCanonicalMethod2
500 Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)"
501
502 _ -> return ()
503
504 | otherwise = return ()
505
506 -- | Warn about unsound/non-canonical 'Monad'/'MonadFail' instance
507 -- declarations. Specifically, the following conditions are verified:
508 --
509 -- In 'Monad' instances declarations:
510 --
511 -- * If 'fail' is overridden it must be canonical
512 -- (i.e. @fail = Control.Monad.Fail.fail@)
513 --
514 -- In 'MonadFail' instance declarations:
515 --
516 -- * Warn if 'fail' is defined backwards
517 -- (i.e. @fail = Control.Monad.fail@).
518 --
519 checkCanonicalMonadFailInstances
520 | cls == monadFailClassName = do
521 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
522 case mbind of
523 FunBind { fun_id = L _ name, fun_matches = mg }
524 | name == failMName, isAliasMG mg == Just failMName_preMFP
525 -> addWarnNonCanonicalMethod1
526 Opt_WarnNonCanonicalMonadFailInstances "fail"
527 "Control.Monad.fail"
528
529 _ -> return ()
530
531 | cls == monadClassName = do
532 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
533 case mbind of
534 FunBind { fun_id = L _ name, fun_matches = mg }
535 | name == failMName_preMFP, isAliasMG mg /= Just failMName
536 -> addWarnNonCanonicalMethod2
537 Opt_WarnNonCanonicalMonadFailInstances "fail"
538 "Control.Monad.Fail.fail"
539 _ -> return ()
540
541 | otherwise = return ()
542
543 -- | Check whether Monoid(mappend) is defined in terms of
544 -- Semigroup((<>)) (and not the other way round). Specifically,
545 -- the following conditions are verified:
546 --
547 -- In 'Monoid' instances declarations:
548 --
549 -- * If 'mappend' is overridden it must be canonical
550 -- (i.e. @mappend = (<>)@)
551 --
552 -- In 'Semigroup' instance declarations:
553 --
554 -- * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@).
555 --
556 checkCanonicalMonoidInstances
557 | cls == semigroupClassName = do
558 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
559 case mbind of
560 FunBind { fun_id = L _ name, fun_matches = mg }
561 | name == sappendName, isAliasMG mg == Just mappendName
562 -> addWarnNonCanonicalMethod1
563 Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend"
564
565 _ -> return ()
566
567 | cls == monoidClassName = do
568 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
569 case mbind of
570 FunBind { fun_id = L _ name, fun_matches = mg }
571 | name == mappendName, isAliasMG mg /= Just sappendName
572 -> addWarnNonCanonicalMethod2NoDefault
573 Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)"
574
575 _ -> return ()
576
577 | otherwise = return ()
578
579 -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\"
580 -- binding, and return @Just rhsName@ if this is the case
581 isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
582 isAliasMG MG {mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = grhss })]}
583 | GRHSs [L _ (GRHS [] body)] lbinds <- grhss
584 , L _ EmptyLocalBinds <- lbinds
585 , L _ (HsVar (L _ rhsName)) <- body = Just rhsName
586 isAliasMG _ = Nothing
587
588 -- got "lhs = rhs" but expected something different
589 addWarnNonCanonicalMethod1 flag lhs rhs = do
590 addWarn (Reason flag) $ vcat
591 [ text "Noncanonical" <+>
592 quotes (text (lhs ++ " = " ++ rhs)) <+>
593 text "definition detected"
594 , instDeclCtxt1 poly_ty
595 , text "Move definition from" <+>
596 quotes (text rhs) <+>
597 text "to" <+> quotes (text lhs)
598 ]
599
600 -- expected "lhs = rhs" but got something else
601 addWarnNonCanonicalMethod2 flag lhs rhs = do
602 addWarn (Reason flag) $ vcat
603 [ text "Noncanonical" <+>
604 quotes (text lhs) <+>
605 text "definition detected"
606 , instDeclCtxt1 poly_ty
607 , text "Either remove definition for" <+>
608 quotes (text lhs) <+> text "or define as" <+>
609 quotes (text (lhs ++ " = " ++ rhs))
610 ]
611
612 -- like above, but method has no default impl
613 addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do
614 addWarn (Reason flag) $ vcat
615 [ text "Noncanonical" <+>
616 quotes (text lhs) <+>
617 text "definition detected"
618 , instDeclCtxt1 poly_ty
619 , text "Define as" <+>
620 quotes (text (lhs ++ " = " ++ rhs))
621 ]
622
623 -- stolen from TcInstDcls
624 instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
625 instDeclCtxt1 hs_inst_ty
626 = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
627
628 inst_decl_ctxt :: SDoc -> SDoc
629 inst_decl_ctxt doc = hang (text "in the instance declaration for")
630 2 (quotes doc <> text ".")
631
632
633 rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars)
634 rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
635 , cid_sigs = uprags, cid_tyfam_insts = ats
636 , cid_overlap_mode = oflag
637 , cid_datafam_insts = adts })
638 = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "an instance declaration") inst_ty
639 ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
640 ; let cls = case hsTyGetAppHead_maybe head_ty' of
641 Nothing -> mkUnboundName (mkTcOccFS (fsLit "<class>"))
642 Just (L _ cls, _) -> cls
643 -- rnLHsInstType has added an error message
644 -- if hsTyGetAppHead_maybe fails
645
646 -- Rename the bindings
647 -- The typechecker (not the renamer) checks that all
648 -- the bindings are for the right class
649 -- (Slightly strangely) when scoped type variables are on, the
650 -- forall-d tyvars scope over the method bindings too
651 ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags
652
653 ; checkCanonicalInstances cls inst_ty' mbinds'
654
655 -- Rename the associated types, and type signatures
656 -- Both need to have the instance type variables in scope
657 ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names)
658 ; ((ats', adts'), more_fvs)
659 <- extendTyVarEnvFVRn ktv_names $
660 do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats
661 ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts
662 ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) }
663
664 ; let all_fvs = meth_fvs `plusFV` more_fvs
665 `plusFV` inst_fvs
666 ; return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = mbinds'
667 , cid_sigs = uprags', cid_tyfam_insts = ats'
668 , cid_overlap_mode = oflag
669 , cid_datafam_insts = adts' },
670 all_fvs) }
671 -- We return the renamed associated data type declarations so
672 -- that they can be entered into the list of type declarations
673 -- for the binding group, but we also keep a copy in the instance.
674 -- The latter is needed for well-formedness checks in the type
675 -- checker (eg, to ensure that all ATs of the instance actually
676 -- receive a declaration).
677 -- NB: Even the copies in the instance declaration carry copies of
678 -- the instance context after renaming. This is a bit
679 -- strange, but should not matter (and it would be more work
680 -- to remove the context).
681
682 rnFamInstEqn :: HsDocContext
683 -> Maybe (Name, [Name]) -- Nothing => not associated
684 -- Just (cls,tvs) => associated,
685 -- and gives class and tyvars of the
686 -- parent instance delc
687 -> [Located RdrName] -- Kind variables from the equation's RHS
688 -> FamInstEqn GhcPs rhs
689 -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
690 -> RnM (FamInstEqn GhcRn rhs', FreeVars)
691 rnFamInstEqn doc mb_cls rhs_kvars
692 (HsIB { hsib_body = FamEqn { feqn_tycon = tycon
693 , feqn_pats = pats
694 , feqn_fixity = fixity
695 , feqn_rhs = payload }}) rn_payload
696 = do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon
697 ; let loc = case pats of
698 [] -> pprPanic "rnFamInstEqn" (ppr tycon)
699 (L loc _ : []) -> loc
700 (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
701
702 ; pat_kity_vars_with_dups <- extractHsTysRdrTyVarsDups pats
703 ; let pat_vars = freeKiTyVarsAllVars $
704 rmDupsInRdrTyVars pat_kity_vars_with_dups
705 -- Use the "...Dups" form because it's needed
706 -- below to report unsed binder on the LHS
707 ; pat_var_names <- mapM (newTyVarNameRn mb_cls . L loc . unLoc) pat_vars
708
709 -- Make sure to filter out the kind variables that were explicitly
710 -- bound in the type patterns.
711 ; let payload_vars = filterOut (`elemRdr` pat_vars) rhs_kvars
712 ; payload_var_names <- mapM (newTyVarNameRn mb_cls) payload_vars
713
714 ; let all_var_names = pat_var_names ++ payload_var_names
715
716 -- All the free vars of the family patterns
717 -- with a sensible binding location
718 ; ((pats', payload'), fvs)
719 <- bindLocalNamesFV all_var_names $
720 do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats
721 ; (payload', rhs_fvs) <- rn_payload doc payload
722
723 -- Report unused binders on the LHS
724 -- See Note [Unused type variables in family instances]
725 ; let groups :: [NonEmpty (Located RdrName)]
726 groups = equivClasses cmpLocated $
727 freeKiTyVarsAllVars pat_kity_vars_with_dups
728 ; tv_nms_dups <- mapM (lookupOccRn . unLoc) $
729 [ tv | (tv :| (_:_)) <- groups ]
730 -- Add to the used variables
731 -- a) any variables that appear *more than once* on the LHS
732 -- e.g. F a Int a = Bool
733 -- b) for associated instances, the variables
734 -- of the instance decl. See
735 -- Note [Unused type variables in family instances]
736 ; let tv_nms_used = extendNameSetList rhs_fvs $
737 inst_tvs ++ tv_nms_dups
738 inst_tvs = case mb_cls of
739 Nothing -> []
740 Just (_, inst_tvs) -> inst_tvs
741 ; warnUnusedTypePatterns pat_var_names tv_nms_used
742
743 -- See Note [Renaming associated types]
744 ; let bad_tvs = case mb_cls of
745 Nothing -> []
746 Just (_,cls_tkvs) -> filter is_bad cls_tkvs
747 var_name_set = mkNameSet all_var_names
748
749 is_bad cls_tkv = cls_tkv `elemNameSet` rhs_fvs
750 && not (cls_tkv `elemNameSet` var_name_set)
751 ; unless (null bad_tvs) (badAssocRhs bad_tvs)
752
753 ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) }
754
755 ; let anon_wcs = concatMap collectAnonWildCards pats'
756 all_ibs = anon_wcs ++ all_var_names
757 -- all_ibs: include anonymous wildcards in the implicit
758 -- binders In a type pattern they behave just like any
759 -- other type variable except for being anoymous. See
760 -- Note [Wildcards in family instances]
761 all_fvs = fvs `addOneFV` unLoc tycon'
762 -- type instance => use, hence addOneFV
763
764 ; return (HsIB { hsib_vars = all_ibs
765 , hsib_closed = True
766 , hsib_body
767 = FamEqn { feqn_tycon = tycon'
768 , feqn_pats = pats'
769 , feqn_fixity = fixity
770 , feqn_rhs = payload' } },
771 all_fvs) }
772
773 rnTyFamInstDecl :: Maybe (Name, [Name])
774 -> TyFamInstDecl GhcPs
775 -> RnM (TyFamInstDecl GhcRn, FreeVars)
776 rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = eqn })
777 = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn
778 ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) }
779
780 rnTyFamInstEqn :: Maybe (Name, [Name])
781 -> TyFamInstEqn GhcPs
782 -> RnM (TyFamInstEqn GhcRn, FreeVars)
783 rnTyFamInstEqn mb_cls eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon
784 , feqn_rhs = rhs }})
785 = do { rhs_kvs <- extractHsTyRdrTyVarsKindVars rhs
786 ; rnFamInstEqn (TySynCtx tycon) mb_cls rhs_kvs eqn rnTySyn }
787
788 rnTyFamDefltEqn :: Name
789 -> TyFamDefltEqn GhcPs
790 -> RnM (TyFamDefltEqn GhcRn, FreeVars)
791 rnTyFamDefltEqn cls (FamEqn { feqn_tycon = tycon
792 , feqn_pats = tyvars
793 , feqn_fixity = fixity
794 , feqn_rhs = rhs })
795 = do { kvs <- extractHsTyRdrTyVarsKindVars rhs
796 ; bindHsQTyVars ctx Nothing (Just cls) kvs tyvars $ \ tyvars' _ ->
797 do { tycon' <- lookupFamInstName (Just cls) tycon
798 ; (rhs', fvs) <- rnLHsType ctx rhs
799 ; return (FamEqn { feqn_tycon = tycon'
800 , feqn_pats = tyvars'
801 , feqn_fixity = fixity
802 , feqn_rhs = rhs' }, fvs) } }
803 where
804 ctx = TyFamilyCtx tycon
805
806 rnDataFamInstDecl :: Maybe (Name, [Name])
807 -> DataFamInstDecl GhcPs
808 -> RnM (DataFamInstDecl GhcRn, FreeVars)
809 rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body =
810 FamEqn { feqn_tycon = tycon
811 , feqn_rhs = rhs }})})
812 = do { rhs_kvs <- extractDataDefnKindVars rhs
813 ; (eqn', fvs) <-
814 rnFamInstEqn (TyDataCtx tycon) mb_cls rhs_kvs eqn rnDataDefn
815 ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }
816
817 -- Renaming of the associated types in instances.
818
819 -- Rename associated type family decl in class
820 rnATDecls :: Name -- Class
821 -> [LFamilyDecl GhcPs]
822 -> RnM ([LFamilyDecl GhcRn], FreeVars)
823 rnATDecls cls at_decls
824 = rnList (rnFamDecl (Just cls)) at_decls
825
826 rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames
827 decl GhcPs -> -- an instance. rnTyFamInstDecl
828 RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl
829 -> Name -- Class
830 -> [Name]
831 -> [Located (decl GhcPs)]
832 -> RnM ([Located (decl GhcRn)], FreeVars)
833 -- Used for data and type family defaults in a class decl
834 -- and the family instance declarations in an instance
835 --
836 -- NB: We allow duplicate associated-type decls;
837 -- See Note [Associated type instances] in TcInstDcls
838 rnATInstDecls rnFun cls tv_ns at_insts
839 = rnList (rnFun (Just (cls, tv_ns))) at_insts
840 -- See Note [Renaming associated types]
841
842 {- Note [Wildcards in family instances]
843 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
844 Wild cards can be used in type/data family instance declarations to indicate
845 that the name of a type variable doesn't matter. Each wild card will be
846 replaced with a new unique type variable. For instance:
847
848 type family F a b :: *
849 type instance F Int _ = Int
850
851 is the same as
852
853 type family F a b :: *
854 type instance F Int b = Int
855
856 This is implemented as follows: during renaming anonymous wild cards
857 '_' are given freshly generated names. These names are collected after
858 renaming (rnFamInstEqn) and used to make new type variables during
859 type checking (tc_fam_ty_pats). One should not confuse these wild
860 cards with the ones from partial type signatures. The latter generate
861 fresh meta-variables whereas the former generate fresh skolems.
862
863 Note [Unused type variables in family instances]
864 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
865 When the flag -fwarn-unused-type-patterns is on, the compiler reports
866 warnings about unused type variables in type-family instances. A
867 tpye variable is considered used (i.e. cannot be turned into a wildcard)
868 when
869
870 * it occurs on the RHS of the family instance
871 e.g. type instance F a b = a -- a is used on the RHS
872
873 * it occurs multiple times in the patterns on the LHS
874 e.g. type instance F a a = Int -- a appears more than once on LHS
875
876 * it is one of the instance-decl variables, for associated types
877 e.g. instance C (a,b) where
878 type T (a,b) = a
879 Here the type pattern in the type instance must be the same as that
880 for the class instance, so
881 type T (a,_) = a
882 would be rejected. So we should not complain about an unused variable b
883
884 As usual, the warnings are not reported for for type variables with names
885 beginning with an underscore.
886
887 Extra-constraints wild cards are not supported in type/data family
888 instance declarations.
889
890 Relevant tickets: #3699, #10586, #10982 and #11451.
891
892 Note [Renaming associated types]
893 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
894 Check that the RHS of the decl mentions only type variables that are explicitly
895 bound on the LHS. For example, this is not ok
896 class C a b where
897 type F a x :: *
898 instance C (p,q) r where
899 type F (p,q) x = (x, r) -- BAD: mentions 'r'
900 c.f. Trac #5515
901
902 Kind variables, on the other hand, are allowed to be implicitly or explicitly
903 bound. As examples, this (#9574) is acceptable:
904 class Funct f where
905 type Codomain f :: *
906 instance Funct ('KProxy :: KProxy o) where
907 -- o is implicitly bound by the kind signature
908 -- of the LHS type pattern ('KProxy)
909 type Codomain 'KProxy = NatTr (Proxy :: o -> *)
910 And this (#14131) is also acceptable:
911 data family Nat :: k -> k -> *
912 -- k is implicitly bound by an invisible kind pattern
913 newtype instance Nat :: (k -> *) -> (k -> *) -> * where
914 Nat :: (forall xx. f xx -> g xx) -> Nat f g
915 We could choose to disallow this, but then associated type families would not
916 be able to be as expressive as top-level type synonyms. For example, this type
917 synonym definition is allowed:
918 type T = (Nothing :: Maybe a)
919 So for parity with type synonyms, we also allow:
920 type family T :: Maybe a
921 type instance T = (Nothing :: Maybe a)
922
923 All this applies only for *instance* declarations. In *class*
924 declarations there is no RHS to worry about, and the class variables
925 can all be in scope (Trac #5862):
926 class Category (x :: k -> k -> *) where
927 type Ob x :: k -> Constraint
928 id :: Ob x a => x a a
929 (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c
930 Here 'k' is in scope in the kind signature, just like 'x'.
931 -}
932
933
934 {-
935 *********************************************************
936 * *
937 \subsection{Stand-alone deriving declarations}
938 * *
939 *********************************************************
940 -}
941
942 rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars)
943 rnSrcDerivDecl (DerivDecl ty deriv_strat overlap)
944 = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving
945 ; deriv_strats_ok <- xoptM LangExt.DerivingStrategies
946 ; unless standalone_deriv_ok (addErr standaloneDerivErr)
947 ; failIfTc (isJust deriv_strat && not deriv_strats_ok) $
948 illegalDerivStrategyErr $ fmap unLoc deriv_strat
949 ; (ty', fvs) <- rnLHsInstType (text "a deriving declaration") ty
950 ; return (DerivDecl ty' deriv_strat overlap, fvs) }
951
952 standaloneDerivErr :: SDoc
953 standaloneDerivErr
954 = hang (text "Illegal standalone deriving declaration")
955 2 (text "Use StandaloneDeriving to enable this extension")
956
957 {-
958 *********************************************************
959 * *
960 \subsection{Rules}
961 * *
962 *********************************************************
963 -}
964
965 rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
966 rnHsRuleDecls (HsRules src rules)
967 = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules
968 ; return (HsRules src rn_rules,fvs) }
969
970 rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
971 rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
972 = do { let rdr_names_w_loc = map get_var vars
973 ; checkDupRdrNames rdr_names_w_loc
974 ; checkShadowedRdrNames rdr_names_w_loc
975 ; names <- newLocalBndrsRn rdr_names_w_loc
976 ; bindHsRuleVars (snd $ unLoc rule_name) vars names $ \ vars' ->
977 do { (lhs', fv_lhs') <- rnLExpr lhs
978 ; (rhs', fv_rhs') <- rnLExpr rhs
979 ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'
980 ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
981 fv_lhs' `plusFV` fv_rhs') } }
982 where
983 get_var (L _ (RuleBndrSig v _)) = v
984 get_var (L _ (RuleBndr v)) = v
985
986 bindHsRuleVars :: RuleName -> [LRuleBndr GhcPs] -> [Name]
987 -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))
988 -> RnM (a, FreeVars)
989 bindHsRuleVars rule_name vars names thing_inside
990 = go vars names $ \ vars' ->
991 bindLocalNamesFV names (thing_inside vars')
992 where
993 doc = RuleCtx rule_name
994
995 go (L l (RuleBndr (L loc _)) : vars) (n : ns) thing_inside
996 = go vars ns $ \ vars' ->
997 thing_inside (L l (RuleBndr (L loc n)) : vars')
998
999 go (L l (RuleBndrSig (L loc _) bsig) : vars) (n : ns) thing_inside
1000 = rnHsSigWcTypeScoped doc bsig $ \ bsig' ->
1001 go vars ns $ \ vars' ->
1002 thing_inside (L l (RuleBndrSig (L loc n) bsig') : vars')
1003
1004 go [] [] thing_inside = thing_inside []
1005 go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
1006
1007 {-
1008 Note [Rule LHS validity checking]
1009 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1010 Check the shape of a transformation rule LHS. Currently we only allow
1011 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
1012 @forall@'d variables.
1013
1014 We used restrict the form of the 'ei' to prevent you writing rules
1015 with LHSs with a complicated desugaring (and hence unlikely to match);
1016 (e.g. a case expression is not allowed: too elaborate.)
1017
1018 But there are legitimate non-trivial args ei, like sections and
1019 lambdas. So it seems simmpler not to check at all, and that is why
1020 check_e is commented out.
1021 -}
1022
1023 checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM ()
1024 checkValidRule rule_name ids lhs' fv_lhs'
1025 = do { -- Check for the form of the LHS
1026 case (validRuleLhs ids lhs') of
1027 Nothing -> return ()
1028 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
1029
1030 -- Check that LHS vars are all bound
1031 ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
1032 ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
1033
1034 validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
1035 -- Nothing => OK
1036 -- Just e => Not ok, and e is the offending sub-expression
1037 validRuleLhs foralls lhs
1038 = checkl lhs
1039 where
1040 checkl (L _ e) = check e
1041
1042 check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
1043 check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2
1044 check (HsAppType e _) = checkl e
1045 check (HsVar (L _ v)) | v `notElem` foralls = Nothing
1046 check other = Just other -- Failure
1047
1048 -- Check an argument
1049 checkl_e (L _ _e) = Nothing -- Was (check_e e); see Note [Rule LHS validity checking]
1050
1051 {- Commented out; see Note [Rule LHS validity checking] above
1052 check_e (HsVar v) = Nothing
1053 check_e (HsPar e) = checkl_e e
1054 check_e (HsLit e) = Nothing
1055 check_e (HsOverLit e) = Nothing
1056
1057 check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
1058 check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2
1059 check_e (NegApp e _) = checkl_e e
1060 check_e (ExplicitList _ es) = checkl_es es
1061 check_e other = Just other -- Fails
1062
1063 checkl_es es = foldr (mplus . checkl_e) Nothing es
1064 -}
1065
1066 badRuleVar :: FastString -> Name -> SDoc
1067 badRuleVar name var
1068 = sep [text "Rule" <+> doubleQuotes (ftext name) <> colon,
1069 text "Forall'd variable" <+> quotes (ppr var) <+>
1070 text "does not appear on left hand side"]
1071
1072 badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc
1073 badRuleLhsErr name lhs bad_e
1074 = sep [text "Rule" <+> pprRuleName name <> colon,
1075 nest 4 (vcat [err,
1076 text "in left-hand side:" <+> ppr lhs])]
1077 $$
1078 text "LHS must be of form (f e1 .. en) where f is not forall'd"
1079 where
1080 err = case bad_e of
1081 HsUnboundVar uv -> text "Not in scope:" <+> ppr uv
1082 _ -> text "Illegal expression:" <+> ppr bad_e
1083
1084 {-
1085 *********************************************************
1086 * *
1087 \subsection{Vectorisation declarations}
1088 * *
1089 *********************************************************
1090 -}
1091
1092 rnHsVectDecl :: VectDecl GhcPs -> RnM (VectDecl GhcRn, FreeVars)
1093 -- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly
1094 -- typecheck a complex right-hand side without invoking 'vectType' from the vectoriser.
1095 rnHsVectDecl (HsVect s var rhs@(L _ (HsVar _)))
1096 = do { var' <- lookupLocatedOccRn var
1097 ; (rhs', fv_rhs) <- rnLExpr rhs
1098 ; return (HsVect s var' rhs', fv_rhs `addOneFV` unLoc var')
1099 }
1100 rnHsVectDecl (HsVect _ _var _rhs)
1101 = failWith $ vcat
1102 [ text "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma"
1103 , text "must be an identifier"
1104 ]
1105 rnHsVectDecl (HsNoVect s var)
1106 = do { var' <- lookupLocatedTopBndrRn var -- only applies to local (not imported) names
1107 ; return (HsNoVect s var', unitFV (unLoc var'))
1108 }
1109 rnHsVectDecl (HsVectTypeIn s isScalar tycon Nothing)
1110 = do { tycon' <- lookupLocatedOccRn tycon
1111 ; return (HsVectTypeIn s isScalar tycon' Nothing, unitFV (unLoc tycon'))
1112 }
1113 rnHsVectDecl (HsVectTypeIn s isScalar tycon (Just rhs_tycon))
1114 = do { tycon' <- lookupLocatedOccRn tycon
1115 ; rhs_tycon' <- lookupLocatedOccRn rhs_tycon
1116 ; return ( HsVectTypeIn s isScalar tycon' (Just rhs_tycon')
1117 , mkFVs [unLoc tycon', unLoc rhs_tycon'])
1118 }
1119 rnHsVectDecl (HsVectTypeOut _ _ _)
1120 = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'"
1121 rnHsVectDecl (HsVectClassIn s cls)
1122 = do { cls' <- lookupLocatedOccRn cls
1123 ; return (HsVectClassIn s cls', unitFV (unLoc cls'))
1124 }
1125 rnHsVectDecl (HsVectClassOut _)
1126 = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
1127 rnHsVectDecl (HsVectInstIn instTy)
1128 = do { (instTy', fvs) <- rnLHsInstType (text "a VECTORISE pragma") instTy
1129 ; return (HsVectInstIn instTy', fvs)
1130 }
1131 rnHsVectDecl (HsVectInstOut _)
1132 = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"
1133
1134 {- **************************************************************
1135 * *
1136 Renaming type, class, instance and role declarations
1137 * *
1138 *****************************************************************
1139
1140 @rnTyDecl@ uses the `global name function' to create a new type
1141 declaration in which local names have been replaced by their original
1142 names, reporting any unknown names.
1143
1144 Renaming type variables is a pain. Because they now contain uniques,
1145 it is necessary to pass in an association list which maps a parsed
1146 tyvar to its @Name@ representation.
1147 In some cases (type signatures of values),
1148 it is even necessary to go over the type first
1149 in order to get the set of tyvars used by it, make an assoc list,
1150 and then go over it again to rename the tyvars!
1151 However, we can also do some scoping checks at the same time.
1152
1153 Note [Dependency analysis of type, class, and instance decls]
1154 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1155 A TyClGroup represents a strongly connected components of
1156 type/class/instance decls, together with the role annotations for the
1157 type/class declarations. The renamer uses strongly connected
1158 comoponent analysis to build these groups. We do this for a number of
1159 reasons:
1160
1161 * Improve kind error messages. Consider
1162
1163 data T f a = MkT f a
1164 data S f a = MkS f (T f a)
1165
1166 This has a kind error, but the error message is better if you
1167 check T first, (fixing its kind) and *then* S. If you do kind
1168 inference together, you might get an error reported in S, which
1169 is jolly confusing. See Trac #4875
1170
1171
1172 * Increase kind polymorphism. See TcTyClsDecls
1173 Note [Grouping of type and class declarations]
1174
1175 Why do the instance declarations participate? At least two reasons
1176
1177 * Consider (Trac #11348)
1178
1179 type family F a
1180 type instance F Int = Bool
1181
1182 data R = MkR (F Int)
1183
1184 type Foo = 'MkR 'True
1185
1186 For Foo to kind-check we need to know that (F Int) ~ Bool. But we won't
1187 know that unless we've looked at the type instance declaration for F
1188 before kind-checking Foo.
1189
1190 * Another example is this (Trac #3990).
1191
1192 data family Complex a
1193 data instance Complex Double = CD {-# UNPACK #-} !Double
1194 {-# UNPACK #-} !Double
1195
1196 data T = T {-# UNPACK #-} !(Complex Double)
1197
1198 Here, to generate the right kind of unpacked implementation for T,
1199 we must have access to the 'data instance' declaration.
1200
1201 * Things become more complicated when we introduce transitive
1202 dependencies through imported definitions, like in this scenario:
1203
1204 A.hs
1205 type family Closed (t :: Type) :: Type where
1206 Closed t = Open t
1207
1208 type family Open (t :: Type) :: Type
1209
1210 B.hs
1211 data Q where
1212 Q :: Closed Bool -> Q
1213
1214 type instance Open Int = Bool
1215
1216 type S = 'Q 'True
1217
1218 Somehow, we must ensure that the instance Open Int = Bool is checked before
1219 the type synonym S. While we know that S depends upon 'Q depends upon Closed,
1220 we have no idea that Closed depends upon Open!
1221
1222 To accomodate for these situations, we ensure that an instance is checked
1223 before every @TyClDecl@ on which it does not depend. That's to say, instances
1224 are checked as early as possible in @tcTyAndClassDecls@.
1225
1226 ------------------------------------
1227 So much for WHY. What about HOW? It's pretty easy:
1228
1229 (1) Rename the type/class, instance, and role declarations
1230 individually
1231
1232 (2) Do strongly-connected component analysis of the type/class decls,
1233 We'll make a TyClGroup for each SCC
1234
1235 In this step we treat a reference to a (promoted) data constructor
1236 K as a dependency on its parent type. Thus
1237 data T = K1 | K2
1238 data S = MkS (Proxy 'K1)
1239 Here S depends on 'K1 and hence on its parent T.
1240
1241 In this step we ignore instances; see
1242 Note [No dependencies on data instances]
1243
1244 (3) Attach roles to the appropriate SCC
1245
1246 (4) Attach instances to the appropriate SCC.
1247 We add an instance decl to SCC when:
1248 all its free types/classes are bound in this SCC or earlier ones
1249
1250 (5) We make an initial TyClGroup, with empty group_tyclds, for any
1251 (orphan) instances that affect only imported types/classes
1252
1253 Steps (3) and (4) are done by the (mapAccumL mk_group) call.
1254
1255 Note [No dependencies on data instances]
1256 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1257 Consider this
1258 data family D a
1259 data instance D Int = D1
1260 data S = MkS (Proxy 'D1)
1261
1262 Here the declaration of S depends on the /data instance/ declaration
1263 for 'D Int'. That makes things a lot more complicated, especially
1264 if the data instance is an associated type of an enclosing class instance.
1265 (And the class instance might have several associated type instances
1266 with different dependency structure!)
1267
1268 Ugh. For now we simply don't allow promotion of data constructors for
1269 data instances. See Note [AFamDataCon: not promoting data family
1270 constructors] in TcEnv
1271 -}
1272
1273
1274 rnTyClDecls :: [TyClGroup GhcPs]
1275 -> RnM ([TyClGroup GhcRn], FreeVars)
1276 -- Rename the declarations and do dependency analysis on them
1277 rnTyClDecls tycl_ds
1278 = do { -- Rename the type/class, instance, and role declaraations
1279 tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl)
1280 (tyClGroupTyClDecls tycl_ds)
1281 ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs)
1282
1283 ; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)
1284 ; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)
1285
1286 -- Do SCC analysis on the type/class decls
1287 ; rdr_env <- getGlobalRdrEnv
1288 ; let tycl_sccs = depAnalTyClDecls rdr_env tycls_w_fvs
1289 role_annot_env = mkRoleAnnotEnv role_annots
1290
1291 inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs
1292 (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map
1293
1294 first_group
1295 | null init_inst_ds = []
1296 | otherwise = [TyClGroup { group_tyclds = []
1297 , group_roles = []
1298 , group_instds = init_inst_ds }]
1299
1300 ((final_inst_ds, orphan_roles), groups)
1301 = mapAccumL mk_group (rest_inst_ds, role_annot_env) tycl_sccs
1302
1303
1304 all_fvs = plusFV (foldr (plusFV . snd) emptyFVs tycls_w_fvs)
1305 (foldr (plusFV . snd) emptyFVs instds_w_fvs)
1306
1307 all_groups = first_group ++ groups
1308
1309 ; ASSERT2( null final_inst_ds, ppr instds_w_fvs $$ ppr inst_ds_map
1310 $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds )
1311 mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles)
1312
1313 ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups)
1314 ; return (all_groups, all_fvs) }
1315 where
1316 mk_group :: (InstDeclFreeVarsMap, RoleAnnotEnv)
1317 -> SCC (LTyClDecl GhcRn)
1318 -> ( (InstDeclFreeVarsMap, RoleAnnotEnv)
1319 , TyClGroup GhcRn )
1320 mk_group (inst_map, role_env) scc
1321 = ((inst_map', role_env'), group)
1322 where
1323 tycl_ds = flattenSCC scc
1324 bndrs = map (tcdName . unLoc) tycl_ds
1325 (inst_ds, inst_map') = getInsts bndrs inst_map
1326 (roles, role_env') = getRoleAnnots bndrs role_env
1327 group = TyClGroup { group_tyclds = tycl_ds
1328 , group_roles = roles
1329 , group_instds = inst_ds }
1330
1331
1332 depAnalTyClDecls :: GlobalRdrEnv
1333 -> [(LTyClDecl GhcRn, FreeVars)]
1334 -> [SCC (LTyClDecl GhcRn)]
1335 -- See Note [Dependency analysis of type, class, and instance decls]
1336 depAnalTyClDecls rdr_env ds_w_fvs
1337 = stronglyConnCompFromEdgedVerticesUniq edges
1338 where
1339 edges :: [ Node Name (LTyClDecl GhcRn) ]
1340 edges = [ DigraphNode d (tcdName (unLoc d)) (map (getParent rdr_env) (nonDetEltsUniqSet fvs))
1341 | (d, fvs) <- ds_w_fvs ]
1342 -- It's OK to use nonDetEltsUFM here as
1343 -- stronglyConnCompFromEdgedVertices is still deterministic
1344 -- even if the edges are in nondeterministic order as explained
1345 -- in Note [Deterministic SCC] in Digraph.
1346
1347 toParents :: GlobalRdrEnv -> NameSet -> NameSet
1348 toParents rdr_env ns
1349 = nonDetFoldUniqSet add emptyNameSet ns
1350 -- It's OK to use nonDetFoldUFM because we immediately forget the
1351 -- ordering by creating a set
1352 where
1353 add n s = extendNameSet s (getParent rdr_env n)
1354
1355 getParent :: GlobalRdrEnv -> Name -> Name
1356 getParent rdr_env n
1357 = case lookupGRE_Name rdr_env n of
1358 Just gre -> case gre_par gre of
1359 ParentIs { par_is = p } -> p
1360 FldParent { par_is = p } -> p
1361 _ -> n
1362 Nothing -> n
1363
1364
1365 {- ******************************************************
1366 * *
1367 Role annotations
1368 * *
1369 ****************************************************** -}
1370
1371 -- | Renames role annotations, returning them as the values in a NameEnv
1372 -- and checks for duplicate role annotations.
1373 -- It is quite convenient to do both of these in the same place.
1374 -- See also Note [Role annotations in the renamer]
1375 rnRoleAnnots :: NameSet
1376 -> [LRoleAnnotDecl GhcPs]
1377 -> RnM [LRoleAnnotDecl GhcRn]
1378 rnRoleAnnots tc_names role_annots
1379 = do { -- Check for duplicates *before* renaming, to avoid
1380 -- lumping together all the unboundNames
1381 let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots
1382 role_annots_cmp (L _ annot1) (L _ annot2)
1383 = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2
1384 ; mapM_ dupRoleAnnotErr dup_annots
1385 ; mapM (wrapLocM rn_role_annot1) no_dups }
1386 where
1387 rn_role_annot1 (RoleAnnotDecl tycon roles)
1388 = do { -- the name is an *occurrence*, but look it up only in the
1389 -- decls defined in this group (see #10263)
1390 tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names)
1391 (text "role annotation")
1392 tycon
1393 ; return $ RoleAnnotDecl tycon' roles }
1394
1395 dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM ()
1396 dupRoleAnnotErr list
1397 = addErrAt loc $
1398 hang (text "Duplicate role annotations for" <+>
1399 quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
1400 2 (vcat $ map pp_role_annot $ NE.toList sorted_list)
1401 where
1402 sorted_list = NE.sortBy cmp_annot list
1403 (L loc first_decl :| _) = sorted_list
1404
1405 pp_role_annot (L loc decl) = hang (ppr decl)
1406 4 (text "-- written at" <+> ppr loc)
1407
1408 cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2
1409
1410 orphanRoleAnnotErr :: LRoleAnnotDecl GhcRn -> RnM ()
1411 orphanRoleAnnotErr (L loc decl)
1412 = addErrAt loc $
1413 hang (text "Role annotation for a type previously declared:")
1414 2 (ppr decl) $$
1415 parens (text "The role annotation must be given where" <+>
1416 quotes (ppr $ roleAnnotDeclName decl) <+>
1417 text "is declared.")
1418
1419
1420 {- Note [Role annotations in the renamer]
1421 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1422 We must ensure that a type's role annotation is put in the same group as the
1423 proper type declaration. This is because role annotations are needed during
1424 type-checking when creating the type's TyCon. So, rnRoleAnnots builds a
1425 NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that
1426 type, if any. Then, this map can be used to add the role annotations to the
1427 groups after dependency analysis.
1428
1429 This process checks for duplicate role annotations, where we must be careful
1430 to do the check *before* renaming to avoid calling all unbound names duplicates
1431 of one another.
1432
1433 The renaming process, as usual, might identify and report errors for unbound
1434 names. We exclude the annotations for unbound names in the annotation
1435 environment to avoid spurious errors for orphaned annotations.
1436
1437 We then (in rnTyClDecls) do a check for orphan role annotations (role
1438 annotations without an accompanying type decl). The check works by folding
1439 over components (of type [[Either (TyClDecl Name) (InstDecl Name)]]), selecting
1440 out the relevant role declarations for each group, as well as diminishing the
1441 annotation environment. After the fold is complete, anything left over in the
1442 name environment must be an orphan, and errors are generated.
1443
1444 An earlier version of this algorithm short-cut the orphan check by renaming
1445 only with names declared in this module. But, this check is insufficient in
1446 the case of staged module compilation (Template Haskell, GHCi).
1447 See #8485. With the new lookup process (which includes types declared in other
1448 modules), we get better error messages, too.
1449 -}
1450
1451
1452 {- ******************************************************
1453 * *
1454 Dependency info for instances
1455 * *
1456 ****************************************************** -}
1457
1458 ----------------------------------------------------------
1459 -- | 'InstDeclFreeVarsMap is an association of an
1460 -- @InstDecl@ with @FreeVars@. The @FreeVars@ are
1461 -- the tycon names that are both
1462 -- a) free in the instance declaration
1463 -- b) bound by this group of type/class/instance decls
1464 type InstDeclFreeVarsMap = [(LInstDecl GhcRn, FreeVars)]
1465
1466 -- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the
1467 -- @FreeVars@ which are *not* the binders of a @TyClDecl@.
1468 mkInstDeclFreeVarsMap :: GlobalRdrEnv
1469 -> NameSet
1470 -> [(LInstDecl GhcRn, FreeVars)]
1471 -> InstDeclFreeVarsMap
1472 mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs
1473 = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs)
1474 | (inst_decl, fvs) <- inst_ds_fvs ]
1475
1476 -- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the
1477 -- @InstDeclFreeVarsMap@ with these entries removed.
1478 -- We call (getInsts tcs instd_map) when we've completed the declarations
1479 -- for 'tcs'. The call returns (inst_decls, instd_map'), where
1480 -- inst_decls are the instance declarations all of
1481 -- whose free vars are now defined
1482 -- instd_map' is the inst-decl map with 'tcs' removed from
1483 -- the free-var set
1484 getInsts :: [Name] -> InstDeclFreeVarsMap
1485 -> ([LInstDecl GhcRn], InstDeclFreeVarsMap)
1486 getInsts bndrs inst_decl_map
1487 = partitionWith pick_me inst_decl_map
1488 where
1489 pick_me :: (LInstDecl GhcRn, FreeVars)
1490 -> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars)
1491 pick_me (decl, fvs)
1492 | isEmptyNameSet depleted_fvs = Left decl
1493 | otherwise = Right (decl, depleted_fvs)
1494 where
1495 depleted_fvs = delFVs bndrs fvs
1496
1497 {- ******************************************************
1498 * *
1499 Renaming a type or class declaration
1500 * *
1501 ****************************************************** -}
1502
1503 rnTyClDecl :: TyClDecl GhcPs
1504 -> RnM (TyClDecl GhcRn, FreeVars)
1505
1506 -- All flavours of type family declarations ("type family", "newtype family",
1507 -- and "data family"), both top level and (for an associated type)
1508 -- in a class decl
1509 rnTyClDecl (FamDecl { tcdFam = decl })
1510 = do { (decl', fvs) <- rnFamDecl Nothing decl
1511 ; return (FamDecl decl', fvs) }
1512
1513 rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,
1514 tcdFixity = fixity, tcdRhs = rhs })
1515 = do { tycon' <- lookupLocatedTopBndrRn tycon
1516 ; kvs <- extractHsTyRdrTyVarsKindVars rhs
1517 ; let doc = TySynCtx tycon
1518 ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs)
1519 ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' _ ->
1520 do { (rhs', fvs) <- rnTySyn doc rhs
1521 ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
1522 , tcdFixity = fixity
1523 , tcdRhs = rhs', tcdFVs = fvs }, fvs) } }
1524
1525 -- "data", "newtype" declarations
1526 -- both top level and (for an associated type) in an instance decl
1527 rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars,
1528 tcdFixity = fixity, tcdDataDefn = defn })
1529 = do { tycon' <- lookupLocatedTopBndrRn tycon
1530 ; kvs <- extractDataDefnKindVars defn
1531 ; let doc = TyDataCtx tycon
1532 ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)
1533 ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs ->
1534 do { (defn', fvs) <- rnDataDefn doc defn
1535 -- See Note [Complete user-supplied kind signatures] in HsDecls
1536 ; typeintype <- xoptM LangExt.TypeInType
1537 ; let cusk = hsTvbAllKinded tyvars' &&
1538 (not typeintype || no_rhs_kvs)
1539 ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
1540 , tcdFixity = fixity
1541 , tcdDataDefn = defn', tcdDataCusk = cusk
1542 , tcdFVs = fvs }, fvs) } }
1543
1544 rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
1545 tcdTyVars = tyvars, tcdFixity = fixity,
1546 tcdFDs = fds, tcdSigs = sigs,
1547 tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
1548 tcdDocs = docs})
1549 = do { lcls' <- lookupLocatedTopBndrRn lcls
1550 ; let cls' = unLoc lcls'
1551 kvs = [] -- No scoped kind vars except those in
1552 -- kind signatures on the tyvars
1553
1554 -- Tyvars scope over superclass context and method signatures
1555 ; ((tyvars', context', fds', ats'), stuff_fvs)
1556 <- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> do
1557 -- Checks for distinct tyvars
1558 { (context', cxt_fvs) <- rnContext cls_doc context
1559 ; fds' <- rnFds fds
1560 -- The fundeps have no free variables
1561 ; (ats', fv_ats) <- rnATDecls cls' ats
1562 ; let fvs = cxt_fvs `plusFV`
1563 fv_ats
1564 ; return ((tyvars', context', fds', ats'), fvs) }
1565
1566 ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltEqn cls') at_defs
1567
1568 -- No need to check for duplicate associated type decls
1569 -- since that is done by RnNames.extendGlobalRdrEnvRn
1570
1571 -- Check the signatures
1572 -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
1573 ; let sig_rdr_names_w_locs = [op | L _ (ClassOpSig False ops _) <- sigs
1574 , op <- ops]
1575 ; checkDupRdrNames sig_rdr_names_w_locs
1576 -- Typechecker is responsible for checking that we only
1577 -- give default-method bindings for things in this class.
1578 -- The renamer *could* check this for class decls, but can't
1579 -- for instance decls.
1580
1581 -- The newLocals call is tiresome: given a generic class decl
1582 -- class C a where
1583 -- op :: a -> a
1584 -- op {| x+y |} (Inl a) = ...
1585 -- op {| x+y |} (Inr b) = ...
1586 -- op {| a*b |} (a*b) = ...
1587 -- we want to name both "x" tyvars with the same unique, so that they are
1588 -- easy to group together in the typechecker.
1589 ; (mbinds', sigs', meth_fvs)
1590 <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs
1591 -- No need to check for duplicate method signatures
1592 -- since that is done by RnNames.extendGlobalRdrEnvRn
1593 -- and the methods are already in scope
1594
1595 -- Haddock docs
1596 ; docs' <- mapM (wrapLocM rnDocDecl) docs
1597
1598 ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs
1599 ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',
1600 tcdTyVars = tyvars', tcdFixity = fixity,
1601 tcdFDs = fds', tcdSigs = sigs',
1602 tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
1603 tcdDocs = docs', tcdFVs = all_fvs },
1604 all_fvs ) }
1605 where
1606 cls_doc = ClassDeclCtx lcls
1607
1608 -- "type" and "type instance" declarations
1609 rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
1610 rnTySyn doc rhs = rnLHsType doc rhs
1611
1612 rnDataDefn :: HsDocContext -> HsDataDefn GhcPs
1613 -> RnM (HsDataDefn GhcRn, FreeVars)
1614 rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1615 , dd_ctxt = context, dd_cons = condecls
1616 , dd_kindSig = m_sig, dd_derivs = derivs })
1617 = do { checkTc (h98_style || null (unLoc context))
1618 (badGadtStupidTheta doc)
1619
1620 ; (m_sig', sig_fvs) <- case m_sig of
1621 Just sig -> first Just <$> rnLHsKind doc sig
1622 Nothing -> return (Nothing, emptyFVs)
1623 ; (context', fvs1) <- rnContext doc context
1624 ; (derivs', fvs3) <- rn_derivs derivs
1625
1626 -- For the constructor declarations, drop the LocalRdrEnv
1627 -- in the GADT case, where the type variables in the declaration
1628 -- do not scope over the constructor signatures
1629 -- data T a where { T1 :: forall b. b-> b }
1630 ; let { zap_lcl_env | h98_style = \ thing -> thing
1631 | otherwise = setLocalRdrEnv emptyLocalRdrEnv }
1632 ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls
1633 -- No need to check for duplicate constructor decls
1634 -- since that is done by RnNames.extendGlobalRdrEnvRn
1635
1636 ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
1637 con_fvs `plusFV` sig_fvs
1638 ; return ( HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1639 , dd_ctxt = context', dd_kindSig = m_sig'
1640 , dd_cons = condecls'
1641 , dd_derivs = derivs' }
1642 , all_fvs )
1643 }
1644 where
1645 h98_style = case condecls of -- Note [Stupid theta]
1646 L _ (ConDeclGADT {}) : _ -> False
1647 _ -> True
1648
1649 rn_derivs (L loc ds)
1650 = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies
1651 ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok)
1652 multipleDerivClausesErr
1653 ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause deriv_strats_ok doc) ds
1654 ; return (L loc ds', fvs) }
1655
1656 rnLHsDerivingClause :: Bool -> HsDocContext -> LHsDerivingClause GhcPs
1657 -> RnM (LHsDerivingClause GhcRn, FreeVars)
1658 rnLHsDerivingClause deriv_strats_ok doc
1659 (L loc (HsDerivingClause { deriv_clause_strategy = dcs
1660 , deriv_clause_tys = L loc' dct }))
1661 = do { failIfTc (isJust dcs && not deriv_strats_ok) $
1662 illegalDerivStrategyErr $ fmap unLoc dcs
1663 ; (dct', fvs) <- mapFvRn (rnHsSigType doc) dct
1664 ; return ( L loc (HsDerivingClause { deriv_clause_strategy = dcs
1665 , deriv_clause_tys = L loc' dct' })
1666 , fvs ) }
1667
1668 badGadtStupidTheta :: HsDocContext -> SDoc
1669 badGadtStupidTheta _
1670 = vcat [text "No context is allowed on a GADT-style data declaration",
1671 text "(You can put a context on each constructor, though.)"]
1672
1673 illegalDerivStrategyErr :: Maybe DerivStrategy -> SDoc
1674 illegalDerivStrategyErr ds
1675 = vcat [ text "Illegal deriving strategy" <> colon <+> maybe empty ppr ds
1676 , text "Use DerivingStrategies to enable this extension" ]
1677
1678 multipleDerivClausesErr :: SDoc
1679 multipleDerivClausesErr
1680 = vcat [ text "Illegal use of multiple, consecutive deriving clauses"
1681 , text "Use DerivingStrategies to allow this" ]
1682
1683 rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested
1684 -- inside an *class decl* for cls
1685 -- used for associated types
1686 -> FamilyDecl GhcPs
1687 -> RnM (FamilyDecl GhcRn, FreeVars)
1688 rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
1689 , fdFixity = fixity
1690 , fdInfo = info, fdResultSig = res_sig
1691 , fdInjectivityAnn = injectivity })
1692 = do { tycon' <- lookupLocatedTopBndrRn tycon
1693 ; kvs <- extractRdrKindSigVars res_sig
1694 ; ((tyvars', res_sig', injectivity'), fv1) <-
1695 bindHsQTyVars doc Nothing mb_cls kvs tyvars $ \ tyvars' _ ->
1696 do { let rn_sig = rnFamResultSig doc
1697 ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig
1698 ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
1699 injectivity
1700 ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }
1701 ; (info', fv2) <- rn_info info
1702 ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars'
1703 , fdFixity = fixity
1704 , fdInfo = info', fdResultSig = res_sig'
1705 , fdInjectivityAnn = injectivity' }
1706 , fv1 `plusFV` fv2) }
1707 where
1708 doc = TyFamilyCtx tycon
1709
1710 ----------------------
1711 rn_info (ClosedTypeFamily (Just eqns))
1712 = do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns
1713 -- no class context,
1714 ; return (ClosedTypeFamily (Just eqns'), fvs) }
1715 rn_info (ClosedTypeFamily Nothing)
1716 = return (ClosedTypeFamily Nothing, emptyFVs)
1717 rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
1718 rn_info DataFamily = return (DataFamily, emptyFVs)
1719
1720 rnFamResultSig :: HsDocContext
1721 -> FamilyResultSig GhcPs
1722 -> RnM (FamilyResultSig GhcRn, FreeVars)
1723 rnFamResultSig _ NoSig
1724 = return (NoSig, emptyFVs)
1725 rnFamResultSig doc (KindSig kind)
1726 = do { (rndKind, ftvs) <- rnLHsKind doc kind
1727 ; return (KindSig rndKind, ftvs) }
1728 rnFamResultSig doc (TyVarSig tvbndr)
1729 = do { -- `TyVarSig` tells us that user named the result of a type family by
1730 -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to
1731 -- be sure that the supplied result name is not identical to an
1732 -- already in-scope type variable from an enclosing class.
1733 --
1734 -- Example of disallowed declaration:
1735 -- class C a b where
1736 -- type F b = a | a -> b
1737 rdr_env <- getLocalRdrEnv
1738 ; let resName = hsLTyVarName tvbndr
1739 ; when (resName `elemLocalRdrEnv` rdr_env) $
1740 addErrAt (getLoc tvbndr) $
1741 (hsep [ text "Type variable", quotes (ppr resName) <> comma
1742 , text "naming a type family result,"
1743 ] $$
1744 text "shadows an already bound type variable")
1745
1746 ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for
1747 -- scoping checks that are irrelevant here
1748 tvbndr $ \ tvbndr' ->
1749 return (TyVarSig tvbndr', unitFV (hsLTyVarName tvbndr')) }
1750
1751 -- Note [Renaming injectivity annotation]
1752 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1753 --
1754 -- During renaming of injectivity annotation we have to make several checks to
1755 -- make sure that it is well-formed. At the moment injectivity annotation
1756 -- consists of a single injectivity condition, so the terms "injectivity
1757 -- annotation" and "injectivity condition" might be used interchangeably. See
1758 -- Note [Injectivity annotation] for a detailed discussion of currently allowed
1759 -- injectivity annotations.
1760 --
1761 -- Checking LHS is simple because the only type variable allowed on the LHS of
1762 -- injectivity condition is the variable naming the result in type family head.
1763 -- Example of disallowed annotation:
1764 --
1765 -- type family Foo a b = r | b -> a
1766 --
1767 -- Verifying RHS of injectivity consists of checking that:
1768 --
1769 -- 1. only variables defined in type family head appear on the RHS (kind
1770 -- variables are also allowed). Example of disallowed annotation:
1771 --
1772 -- type family Foo a = r | r -> b
1773 --
1774 -- 2. for associated types the result variable does not shadow any of type
1775 -- class variables. Example of disallowed annotation:
1776 --
1777 -- class Foo a b where
1778 -- type F a = b | b -> a
1779 --
1780 -- Breaking any of these assumptions results in an error.
1781
1782 -- | Rename injectivity annotation. Note that injectivity annotation is just the
1783 -- part after the "|". Everything that appears before it is renamed in
1784 -- rnFamDecl.
1785 rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in
1786 -- type family head
1787 -> LFamilyResultSig GhcRn -- ^ Result signature
1788 -> LInjectivityAnn GhcPs -- ^ Injectivity annotation
1789 -> RnM (LInjectivityAnn GhcRn)
1790 rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv))
1791 (L srcSpan (InjectivityAnn injFrom injTo))
1792 = do
1793 { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors)
1794 <- askNoErrs $
1795 bindLocalNames [hsLTyVarName resTv] $
1796 -- The return type variable scopes over the injectivity annotation
1797 -- e.g. type family F a = (r::*) | r -> a
1798 do { injFrom' <- rnLTyVar injFrom
1799 ; injTo' <- mapM rnLTyVar injTo
1800 ; return $ L srcSpan (InjectivityAnn injFrom' injTo') }
1801
1802 ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs
1803 resName = hsLTyVarName resTv
1804 -- See Note [Renaming injectivity annotation]
1805 lhsValid = EQ == (stableNameCmp resName (unLoc injFrom'))
1806 rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames
1807
1808 -- if renaming of type variables ended with errors (eg. there were
1809 -- not-in-scope variables) don't check the validity of injectivity
1810 -- annotation. This gives better error messages.
1811 ; when (noRnErrors && not lhsValid) $
1812 addErrAt (getLoc injFrom)
1813 ( vcat [ text $ "Incorrect type variable on the LHS of "
1814 ++ "injectivity condition"
1815 , nest 5
1816 ( vcat [ text "Expected :" <+> ppr resName
1817 , text "Actual :" <+> ppr injFrom ])])
1818
1819 ; when (noRnErrors && not (Set.null rhsValid)) $
1820 do { let errorVars = Set.toList rhsValid
1821 ; addErrAt srcSpan $ ( hsep
1822 [ text "Unknown type variable" <> plural errorVars
1823 , text "on the RHS of injectivity condition:"
1824 , interpp'SP errorVars ] ) }
1825
1826 ; return injDecl' }
1827
1828 -- We can only hit this case when the user writes injectivity annotation without
1829 -- naming the result:
1830 --
1831 -- type family F a | result -> a
1832 -- type family F a :: * | result -> a
1833 --
1834 -- So we rename injectivity annotation like we normally would except that
1835 -- this time we expect "result" to be reported not in scope by rnLTyVar.
1836 rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) =
1837 setSrcSpan srcSpan $ do
1838 (injDecl', _) <- askNoErrs $ do
1839 injFrom' <- rnLTyVar injFrom
1840 injTo' <- mapM rnLTyVar injTo
1841 return $ L srcSpan (InjectivityAnn injFrom' injTo')
1842 return $ injDecl'
1843
1844 {-
1845 Note [Stupid theta]
1846 ~~~~~~~~~~~~~~~~~~~
1847 Trac #3850 complains about a regression wrt 6.10 for
1848 data Show a => T a
1849 There is no reason not to allow the stupid theta if there are no data
1850 constructors. It's still stupid, but does no harm, and I don't want
1851 to cause programs to break unnecessarily (notably HList). So if there
1852 are no data constructors we allow h98_style = True
1853 -}
1854
1855
1856 {- *****************************************************
1857 * *
1858 Support code for type/data declarations
1859 * *
1860 ***************************************************** -}
1861
1862 ---------------
1863 badAssocRhs :: [Name] -> RnM ()
1864 badAssocRhs ns
1865 = addErr (hang (text "The RHS of an associated type declaration mentions"
1866 <+> text "out-of-scope variable" <> plural ns
1867 <+> pprWithCommas (quotes . ppr) ns)
1868 2 (text "All such variables must be bound on the LHS"))
1869
1870 -----------------
1871 rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)
1872 rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
1873
1874 rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
1875 rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
1876 , con_cxt = mcxt, con_details = details
1877 , con_doc = mb_doc })
1878 = do { _ <- addLocM checkConName name
1879 ; new_name <- lookupLocatedTopBndrRn name
1880 ; mb_doc' <- rnMbLHsDoc mb_doc
1881
1882 ; let doc = ConDeclCtx [new_name]
1883 qtvs' = qtvs `orElse` mkHsQTvs []
1884 body_kvs = [] -- Consider data T a = forall (b::k). MkT (...)
1885 -- The 'k' will already be in scope from the
1886 -- bindHsQTyVars for the entire DataDecl
1887 -- So there can be no new body_kvs here
1888 ; bindHsQTyVars doc (Just $ inHsDocContext doc) Nothing body_kvs qtvs' $
1889 \new_tyvars _ -> do
1890 { (new_context, fvs1) <- case mcxt of
1891 Nothing -> return (Nothing,emptyFVs)
1892 Just lcxt -> do { (lctx',fvs) <- rnContext doc lcxt
1893 ; return (Just lctx',fvs) }
1894 ; (new_details, fvs2) <- rnConDeclDetails (unLoc new_name) doc details
1895 ; let (new_details',fvs3) = (new_details,emptyFVs)
1896 ; traceRn "rnConDecl" (ppr name <+> vcat
1897 [ text "qtvs:" <+> ppr qtvs
1898 , text "qtvs':" <+> ppr qtvs' ])
1899 ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
1900 new_tyvars' = case qtvs of
1901 Nothing -> Nothing
1902 Just _ -> Just new_tyvars
1903 ; return (decl { con_name = new_name, con_qvars = new_tyvars'
1904 , con_cxt = new_context, con_details = new_details'
1905 , con_doc = mb_doc' },
1906 all_fvs) }}
1907
1908 rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty
1909 , con_doc = mb_doc })
1910 = do { mapM_ (addLocM checkConName) names
1911 ; new_names <- mapM lookupLocatedTopBndrRn names
1912 ; let doc = ConDeclCtx new_names
1913 ; mb_doc' <- rnMbLHsDoc mb_doc
1914
1915 ; (ty', fvs) <- rnHsSigType doc ty
1916 ; traceRn "rnConDecl" (ppr names <+> vcat
1917 [ text "fvs:" <+> ppr fvs ])
1918 ; return (decl { con_names = new_names, con_type = ty'
1919 , con_doc = mb_doc' },
1920 fvs) }
1921
1922 rnConDeclDetails
1923 :: Name
1924 -> HsDocContext
1925 -> HsConDetails (LHsType GhcPs) (Located [LConDeclField GhcPs])
1926 -> RnM (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),
1927 FreeVars)
1928 rnConDeclDetails _ doc (PrefixCon tys)
1929 = do { (new_tys, fvs) <- rnLHsTypes doc tys
1930 ; return (PrefixCon new_tys, fvs) }
1931
1932 rnConDeclDetails _ doc (InfixCon ty1 ty2)
1933 = do { (new_ty1, fvs1) <- rnLHsType doc ty1
1934 ; (new_ty2, fvs2) <- rnLHsType doc ty2
1935 ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
1936
1937 rnConDeclDetails con doc (RecCon (L l fields))
1938 = do { fls <- lookupConstructorFields con
1939 ; (new_fields, fvs) <- rnConDeclFields doc fls fields
1940 -- No need to check for duplicate fields
1941 -- since that is done by RnNames.extendGlobalRdrEnvRn
1942 ; return (RecCon (L l new_fields), fvs) }
1943
1944 -------------------------------------------------
1945
1946 -- | Brings pattern synonym names and also pattern synonym selectors
1947 -- from record pattern synonyms into scope.
1948 extendPatSynEnv :: HsValBinds GhcPs -> MiniFixityEnv
1949 -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a
1950 extendPatSynEnv val_decls local_fix_env thing = do {
1951 names_with_fls <- new_ps val_decls
1952 ; let pat_syn_bndrs = concat [ name: map flSelector fields
1953 | (name, fields) <- names_with_fls ]
1954 ; let avails = map avail pat_syn_bndrs
1955 ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env
1956
1957 ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls
1958 final_gbl_env = gbl_env { tcg_field_env = field_env' }
1959 ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }
1960 where
1961 new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]
1962 new_ps (ValBindsIn binds _) = foldrBagM new_ps' [] binds
1963 new_ps _ = panic "new_ps"
1964
1965 new_ps' :: LHsBindLR GhcPs GhcPs
1966 -> [(Name, [FieldLabel])]
1967 -> TcM [(Name, [FieldLabel])]
1968 new_ps' bind names
1969 | L bind_loc (PatSynBind (PSB { psb_id = L _ n
1970 , psb_args = RecordPatSyn as })) <- bind
1971 = do
1972 bnd_name <- newTopSrcBinder (L bind_loc n)
1973 let rnames = map recordPatSynSelectorId as
1974 mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs
1975 mkFieldOcc (L l name) = L l (FieldOcc (L l name) PlaceHolder)
1976 field_occs = map mkFieldOcc rnames
1977 flds <- mapM (newRecordSelector False [bnd_name]) field_occs
1978 return ((bnd_name, flds): names)
1979 | L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind
1980 = do
1981 bnd_name <- newTopSrcBinder (L bind_loc n)
1982 return ((bnd_name, []): names)
1983 | otherwise
1984 = return names
1985
1986 {-
1987 *********************************************************
1988 * *
1989 \subsection{Support code to rename types}
1990 * *
1991 *********************************************************
1992 -}
1993
1994 rnFds :: [Located (FunDep (Located RdrName))]
1995 -> RnM [Located (FunDep (Located Name))]
1996 rnFds fds
1997 = mapM (wrapLocM rn_fds) fds
1998 where
1999 rn_fds (tys1, tys2)
2000 = do { tys1' <- rnHsTyVars tys1
2001 ; tys2' <- rnHsTyVars tys2
2002 ; return (tys1', tys2') }
2003
2004 rnHsTyVars :: [Located RdrName] -> RnM [Located Name]
2005 rnHsTyVars tvs = mapM rnHsTyVar tvs
2006
2007 rnHsTyVar :: Located RdrName -> RnM (Located Name)
2008 rnHsTyVar (L l tyvar) = do
2009 tyvar' <- lookupOccRn tyvar
2010 return (L l tyvar')
2011
2012 {-
2013 *********************************************************
2014 * *
2015 findSplice
2016 * *
2017 *********************************************************
2018
2019 This code marches down the declarations, looking for the first
2020 Template Haskell splice. As it does so it
2021 a) groups the declarations into a HsGroup
2022 b) runs any top-level quasi-quotes
2023 -}
2024
2025 findSplice :: [LHsDecl GhcPs]
2026 -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
2027 findSplice ds = addl emptyRdrGroup ds
2028
2029 addl :: HsGroup GhcPs -> [LHsDecl GhcPs]
2030 -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
2031 -- This stuff reverses the declarations (again) but it doesn't matter
2032 addl gp [] = return (gp, Nothing)
2033 addl gp (L l d : ds) = add gp l d ds
2034
2035
2036 add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs]
2037 -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
2038
2039 -- #10047: Declaration QuasiQuoters are expanded immediately, without
2040 -- causing a group split
2041 add gp _ (SpliceD (SpliceDecl (L _ qq@HsQuasiQuote{}) _)) ds
2042 = do { (ds', _) <- rnTopSpliceDecls qq
2043 ; addl gp (ds' ++ ds)
2044 }
2045
2046 add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
2047 = do { -- We've found a top-level splice. If it is an *implicit* one
2048 -- (i.e. a naked top level expression)
2049 case flag of
2050 ExplicitSplice -> return ()
2051 ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell
2052 ; unless th_on $ setSrcSpan loc $
2053 failWith badImplicitSplice }
2054
2055 ; return (gp, Just (splice, ds)) }
2056 where
2057 badImplicitSplice = text "Parse error: module header, import declaration"
2058 $$ text "or top-level declaration expected."
2059
2060 -- Class declarations: pull out the fixity signatures to the top
2061 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
2062 | isClassDecl d
2063 = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
2064 addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
2065 | otherwise
2066 = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
2067
2068 -- Signatures: fixity sigs go a different place than all others
2069 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
2070 = addl (gp {hs_fixds = L l f : ts}) ds
2071 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
2072 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
2073
2074 -- Value declarations: use add_bind
2075 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
2076 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
2077
2078 -- Role annotations: added to the TyClGroup
2079 add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD d) ds
2080 = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds
2081
2082 -- NB instance declarations go into TyClGroups. We throw them into the first
2083 -- group, just as we do for the TyClD case. The renamer will go on to group
2084 -- and order them later.
2085 add gp@(HsGroup {hs_tyclds = ts}) l (InstD d) ds
2086 = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds
2087
2088 -- The rest are routine
2089 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
2090 = addl (gp { hs_derivds = L l d : ts }) ds
2091 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
2092 = addl (gp { hs_defds = L l d : ts }) ds
2093 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
2094 = addl (gp { hs_fords = L l d : ts }) ds
2095 add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
2096 = addl (gp { hs_warnds = L l d : ts }) ds
2097 add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
2098 = addl (gp { hs_annds = L l d : ts }) ds
2099 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
2100 = addl (gp { hs_ruleds = L l d : ts }) ds
2101 add gp@(HsGroup {hs_vects = ts}) l (VectD d) ds
2102 = addl (gp { hs_vects = L l d : ts }) ds
2103 add gp l (DocD d) ds
2104 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
2105
2106 add_tycld :: LTyClDecl a -> [TyClGroup a] -> [TyClGroup a]
2107 add_tycld d [] = [TyClGroup { group_tyclds = [d]
2108 , group_roles = []
2109 , group_instds = []
2110 }
2111 ]
2112 add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
2113 = ds { group_tyclds = d : tyclds } : dss
2114
2115 add_instd :: LInstDecl a -> [TyClGroup a] -> [TyClGroup a]
2116 add_instd d [] = [TyClGroup { group_tyclds = []
2117 , group_roles = []
2118 , group_instds = [d]
2119 }
2120 ]
2121 add_instd d (ds@(TyClGroup { group_instds = instds }):dss)
2122 = ds { group_instds = d : instds } : dss
2123
2124 add_role_annot :: LRoleAnnotDecl a -> [TyClGroup a] -> [TyClGroup a]
2125 add_role_annot d [] = [TyClGroup { group_tyclds = []
2126 , group_roles = [d]
2127 , group_instds = []
2128 }
2129 ]
2130 add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
2131 = tycls { group_roles = d : roles } : rest
2132
2133 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
2134 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
2135 add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
2136
2137 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
2138 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
2139 add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"