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