b182382381bb3110eefb95e57e88f9c23aa80836
[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 ; tycls_w_fvs <- addBootDeps tycls_w_fvs
1287 -- TBD must add_boot_deps to instds_w_fvs?
1288
1289 -- Do SCC analysis on the type/class decls
1290 ; rdr_env <- getGlobalRdrEnv
1291 ; let tycl_sccs = depAnalTyClDecls rdr_env tycls_w_fvs
1292 role_annot_env = mkRoleAnnotEnv role_annots
1293
1294 inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs
1295 (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map
1296
1297 first_group
1298 | null init_inst_ds = []
1299 | otherwise = [TyClGroup { group_tyclds = []
1300 , group_roles = []
1301 , group_instds = init_inst_ds }]
1302
1303 ((final_inst_ds, orphan_roles), groups)
1304 = mapAccumL mk_group (rest_inst_ds, role_annot_env) tycl_sccs
1305
1306
1307 all_fvs = plusFV (foldr (plusFV . snd) emptyFVs tycls_w_fvs)
1308 (foldr (plusFV . snd) emptyFVs instds_w_fvs)
1309
1310 all_groups = first_group ++ groups
1311
1312 ; ASSERT2( null final_inst_ds, ppr instds_w_fvs $$ ppr inst_ds_map
1313 $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds )
1314 mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles)
1315
1316 ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups)
1317 ; return (all_groups, all_fvs) }
1318 where
1319 mk_group :: (InstDeclFreeVarsMap, RoleAnnotEnv)
1320 -> SCC (LTyClDecl GhcRn)
1321 -> ( (InstDeclFreeVarsMap, RoleAnnotEnv)
1322 , TyClGroup GhcRn )
1323 mk_group (inst_map, role_env) scc
1324 = ((inst_map', role_env'), group)
1325 where
1326 tycl_ds = flattenSCC scc
1327 bndrs = map (tcdName . unLoc) tycl_ds
1328 (inst_ds, inst_map') = getInsts bndrs inst_map
1329 (roles, role_env') = getRoleAnnots bndrs role_env
1330 group = TyClGroup { group_tyclds = tycl_ds
1331 , group_roles = roles
1332 , group_instds = inst_ds }
1333
1334
1335 depAnalTyClDecls :: GlobalRdrEnv
1336 -> [(LTyClDecl GhcRn, FreeVars)]
1337 -> [SCC (LTyClDecl GhcRn)]
1338 -- See Note [Dependency analysis of type, class, and instance decls]
1339 depAnalTyClDecls rdr_env ds_w_fvs
1340 = stronglyConnCompFromEdgedVerticesUniq edges
1341 where
1342 edges :: [ Node Name (LTyClDecl GhcRn) ]
1343 edges = [ DigraphNode d (tcdName (unLoc d)) (map (getParent rdr_env) (nonDetEltsUniqSet fvs))
1344 | (d, fvs) <- ds_w_fvs ]
1345 -- It's OK to use nonDetEltsUFM here as
1346 -- stronglyConnCompFromEdgedVertices is still deterministic
1347 -- even if the edges are in nondeterministic order as explained
1348 -- in Note [Deterministic SCC] in Digraph.
1349
1350 toParents :: GlobalRdrEnv -> NameSet -> NameSet
1351 toParents rdr_env ns
1352 = nonDetFoldUniqSet add emptyNameSet ns
1353 -- It's OK to use nonDetFoldUFM because we immediately forget the
1354 -- ordering by creating a set
1355 where
1356 add n s = extendNameSet s (getParent rdr_env n)
1357
1358 getParent :: GlobalRdrEnv -> Name -> Name
1359 getParent rdr_env n
1360 = case lookupGRE_Name rdr_env n of
1361 Just gre -> case gre_par gre of
1362 ParentIs { par_is = p } -> p
1363 FldParent { par_is = p } -> p
1364 _ -> n
1365 Nothing -> n
1366
1367
1368 {- Note [Extra dependencies from .hs-boot files]
1369 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1370 This is a long story, so buckle in.
1371
1372 **Dependencies via hs-boot files are not obvious.** Consider the following case:
1373
1374 A.hs-boot
1375 module A where
1376 data A1
1377
1378 B.hs
1379 module B where
1380 import {-# SOURCE #-} A
1381 type B1 = A1
1382
1383 A.hs
1384 module A where
1385 import B
1386 data A2 = MkA2 B1
1387 data A1 = MkA1 A2
1388
1389 Here A2 is really recursive (via B1), but we won't see that easily when
1390 doing dependency analysis when compiling A.hs. When we look at A2,
1391 we see that its free variables are simply B1, but without (recursively) digging
1392 into the definition of B1 will we see that it actually refers to A1 via an
1393 hs-boot file.
1394
1395 **Recursive declarations, even those broken by an hs-boot file, need to
1396 be type-checked together.** Whenever we refer to a declaration via
1397 an hs-boot file, we must be careful not to force the TyThing too early:
1398 ala Note [Tying the knot] if we force the TyThing before we have
1399 defined it ourselves in the local type environment, GHC will error.
1400
1401 Conservatively, then, it would make sense that we to typecheck A1
1402 and A2 from the previous example together, because the two types are
1403 truly mutually recursive through B1.
1404
1405 If we are being clever, we might observe that while kind-checking
1406 A2, we don't actually need to force the TyThing for A1: B1
1407 independently records its kind, so there is no need to go "deeper".
1408 But then we are in an uncomfortable situation where we have
1409 constructed a TyThing for A2 before we have checked A1, and we
1410 have to be absolutely certain we don't force it too deeply until
1411 we get around to kind checking A1, which could be for a very long
1412 time.
1413
1414 Indeed, with datatype promotion, we may very well need to look
1415 at the type of MkA2 before we have kind-checked A1: consider,
1416
1417 data T = MkT (Proxy 'MkA2)
1418
1419 To promote MkA2, we need to lift its type to the kind level.
1420 We never tested this, but it seems likely A1 would get poked
1421 at this point.
1422
1423 **Here's what we do instead.** So it is expedient for us to
1424 make sure A1 and A2 are kind checked together in a loop.
1425 To ensure that our dependency analysis can catch this,
1426 we add a dependency:
1427
1428 - from every local declaration
1429 - to everything that comes from this module's .hs-boot file
1430 (this is gotten from sb_tcs in the SelfBootInfo).
1431
1432 In this case, we'll add an edges
1433
1434 - from A1 to A2 (but that edge is there already)
1435 - from A2 to A1 (which is new)
1436
1437 Well, not quite *every* declaration. Imagine module A
1438 above had another datatype declaration:
1439
1440 data A3 = A3 Int
1441
1442 Even though A3 has a dependency (on Int), all its dependencies are from things
1443 that live on other packages. Since we don't have mutual dependencies across
1444 packages, it is safe not to add the dependencies on the .hs-boot stuff to A2.
1445
1446 Hence function nameIsHomePackageImport.
1447
1448 Note that this is fairly conservative: it essentially implies that
1449 EVERY type declaration in this modules hs-boot file will be kind-checked
1450 together in one giant loop (and furthermore makes every other type
1451 in the module depend on this loop). This is perhaps less than ideal, because
1452 the larger a recursive group, the less polymorphism available (we
1453 cannot infer a type to be polymorphically instantiated while we
1454 are inferring its kind), but no one has hollered about this (yet!)
1455 -}
1456
1457 addBootDeps :: [(LTyClDecl GhcRn, FreeVars)]
1458 -> RnM [(LTyClDecl GhcRn, FreeVars)]
1459 -- See Note [Extra dependencies from .hs-boot files]
1460 addBootDeps ds_w_fvs
1461 = do { tcg_env <- getGblEnv
1462 ; let this_mod = tcg_mod tcg_env
1463 boot_info = tcg_self_boot tcg_env
1464
1465 add_boot_deps :: [(LTyClDecl GhcRn, FreeVars)]
1466 -> [(LTyClDecl GhcRn, FreeVars)]
1467 add_boot_deps ds_w_fvs
1468 = case boot_info of
1469 SelfBoot { sb_tcs = tcs } | not (isEmptyNameSet tcs)
1470 -> map (add_one tcs) ds_w_fvs
1471 _ -> ds_w_fvs
1472
1473 add_one :: NameSet -> (LTyClDecl GhcRn, FreeVars)
1474 -> (LTyClDecl GhcRn, FreeVars)
1475 add_one tcs pr@(decl,fvs)
1476 | has_local_imports fvs = (decl, fvs `plusFV` tcs)
1477 | otherwise = pr
1478
1479 has_local_imports fvs
1480 = nameSetAny (nameIsHomePackageImport this_mod) fvs
1481 ; return (add_boot_deps ds_w_fvs) }
1482
1483
1484
1485 {- ******************************************************
1486 * *
1487 Role annotations
1488 * *
1489 ****************************************************** -}
1490
1491 -- | Renames role annotations, returning them as the values in a NameEnv
1492 -- and checks for duplicate role annotations.
1493 -- It is quite convenient to do both of these in the same place.
1494 -- See also Note [Role annotations in the renamer]
1495 rnRoleAnnots :: NameSet
1496 -> [LRoleAnnotDecl GhcPs]
1497 -> RnM [LRoleAnnotDecl GhcRn]
1498 rnRoleAnnots tc_names role_annots
1499 = do { -- Check for duplicates *before* renaming, to avoid
1500 -- lumping together all the unboundNames
1501 let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots
1502 role_annots_cmp (L _ annot1) (L _ annot2)
1503 = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2
1504 ; mapM_ dupRoleAnnotErr dup_annots
1505 ; mapM (wrapLocM rn_role_annot1) no_dups }
1506 where
1507 rn_role_annot1 (RoleAnnotDecl tycon roles)
1508 = do { -- the name is an *occurrence*, but look it up only in the
1509 -- decls defined in this group (see #10263)
1510 tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names)
1511 (text "role annotation")
1512 tycon
1513 ; return $ RoleAnnotDecl tycon' roles }
1514
1515 dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM ()
1516 dupRoleAnnotErr list
1517 = addErrAt loc $
1518 hang (text "Duplicate role annotations for" <+>
1519 quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
1520 2 (vcat $ map pp_role_annot $ NE.toList sorted_list)
1521 where
1522 sorted_list = NE.sortBy cmp_annot list
1523 (L loc first_decl :| _) = sorted_list
1524
1525 pp_role_annot (L loc decl) = hang (ppr decl)
1526 4 (text "-- written at" <+> ppr loc)
1527
1528 cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2
1529
1530 orphanRoleAnnotErr :: LRoleAnnotDecl GhcRn -> RnM ()
1531 orphanRoleAnnotErr (L loc decl)
1532 = addErrAt loc $
1533 hang (text "Role annotation for a type previously declared:")
1534 2 (ppr decl) $$
1535 parens (text "The role annotation must be given where" <+>
1536 quotes (ppr $ roleAnnotDeclName decl) <+>
1537 text "is declared.")
1538
1539
1540 {- Note [Role annotations in the renamer]
1541 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1542 We must ensure that a type's role annotation is put in the same group as the
1543 proper type declaration. This is because role annotations are needed during
1544 type-checking when creating the type's TyCon. So, rnRoleAnnots builds a
1545 NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that
1546 type, if any. Then, this map can be used to add the role annotations to the
1547 groups after dependency analysis.
1548
1549 This process checks for duplicate role annotations, where we must be careful
1550 to do the check *before* renaming to avoid calling all unbound names duplicates
1551 of one another.
1552
1553 The renaming process, as usual, might identify and report errors for unbound
1554 names. We exclude the annotations for unbound names in the annotation
1555 environment to avoid spurious errors for orphaned annotations.
1556
1557 We then (in rnTyClDecls) do a check for orphan role annotations (role
1558 annotations without an accompanying type decl). The check works by folding
1559 over components (of type [[Either (TyClDecl Name) (InstDecl Name)]]), selecting
1560 out the relevant role declarations for each group, as well as diminishing the
1561 annotation environment. After the fold is complete, anything left over in the
1562 name environment must be an orphan, and errors are generated.
1563
1564 An earlier version of this algorithm short-cut the orphan check by renaming
1565 only with names declared in this module. But, this check is insufficient in
1566 the case of staged module compilation (Template Haskell, GHCi).
1567 See #8485. With the new lookup process (which includes types declared in other
1568 modules), we get better error messages, too.
1569 -}
1570
1571
1572 {- ******************************************************
1573 * *
1574 Dependency info for instances
1575 * *
1576 ****************************************************** -}
1577
1578 ----------------------------------------------------------
1579 -- | 'InstDeclFreeVarsMap is an association of an
1580 -- @InstDecl@ with @FreeVars@. The @FreeVars@ are
1581 -- the tycon names that are both
1582 -- a) free in the instance declaration
1583 -- b) bound by this group of type/class/instance decls
1584 type InstDeclFreeVarsMap = [(LInstDecl GhcRn, FreeVars)]
1585
1586 -- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the
1587 -- @FreeVars@ which are *not* the binders of a @TyClDecl@.
1588 mkInstDeclFreeVarsMap :: GlobalRdrEnv
1589 -> NameSet
1590 -> [(LInstDecl GhcRn, FreeVars)]
1591 -> InstDeclFreeVarsMap
1592 mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs
1593 = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs)
1594 | (inst_decl, fvs) <- inst_ds_fvs ]
1595
1596 -- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the
1597 -- @InstDeclFreeVarsMap@ with these entries removed.
1598 -- We call (getInsts tcs instd_map) when we've completed the declarations
1599 -- for 'tcs'. The call returns (inst_decls, instd_map'), where
1600 -- inst_decls are the instance declarations all of
1601 -- whose free vars are now defined
1602 -- instd_map' is the inst-decl map with 'tcs' removed from
1603 -- the free-var set
1604 getInsts :: [Name] -> InstDeclFreeVarsMap
1605 -> ([LInstDecl GhcRn], InstDeclFreeVarsMap)
1606 getInsts bndrs inst_decl_map
1607 = partitionWith pick_me inst_decl_map
1608 where
1609 pick_me :: (LInstDecl GhcRn, FreeVars)
1610 -> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars)
1611 pick_me (decl, fvs)
1612 | isEmptyNameSet depleted_fvs = Left decl
1613 | otherwise = Right (decl, depleted_fvs)
1614 where
1615 depleted_fvs = delFVs bndrs fvs
1616
1617 {- ******************************************************
1618 * *
1619 Renaming a type or class declaration
1620 * *
1621 ****************************************************** -}
1622
1623 rnTyClDecl :: TyClDecl GhcPs
1624 -> RnM (TyClDecl GhcRn, FreeVars)
1625
1626 -- All flavours of type family declarations ("type family", "newtype family",
1627 -- and "data family"), both top level and (for an associated type)
1628 -- in a class decl
1629 rnTyClDecl (FamDecl { tcdFam = decl })
1630 = do { (decl', fvs) <- rnFamDecl Nothing decl
1631 ; return (FamDecl decl', fvs) }
1632
1633 rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,
1634 tcdFixity = fixity, tcdRhs = rhs })
1635 = do { tycon' <- lookupLocatedTopBndrRn tycon
1636 ; kvs <- extractHsTyRdrTyVarsKindVars rhs
1637 ; let doc = TySynCtx tycon
1638 ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs)
1639 ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' _ ->
1640 do { (rhs', fvs) <- rnTySyn doc rhs
1641 ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
1642 , tcdFixity = fixity
1643 , tcdRhs = rhs', tcdFVs = fvs }, fvs) } }
1644
1645 -- "data", "newtype" declarations
1646 -- both top level and (for an associated type) in an instance decl
1647 rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars,
1648 tcdFixity = fixity, tcdDataDefn = defn })
1649 = do { tycon' <- lookupLocatedTopBndrRn tycon
1650 ; kvs <- extractDataDefnKindVars defn
1651 ; let doc = TyDataCtx tycon
1652 ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)
1653 ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs ->
1654 do { (defn', fvs) <- rnDataDefn doc defn
1655 -- See Note [Complete user-supplied kind signatures] in HsDecls
1656 ; typeintype <- xoptM LangExt.TypeInType
1657 ; let cusk = hsTvbAllKinded tyvars' &&
1658 (not typeintype || no_rhs_kvs)
1659 ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
1660 , tcdFixity = fixity
1661 , tcdDataDefn = defn', tcdDataCusk = cusk
1662 , tcdFVs = fvs }, fvs) } }
1663
1664 rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
1665 tcdTyVars = tyvars, tcdFixity = fixity,
1666 tcdFDs = fds, tcdSigs = sigs,
1667 tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
1668 tcdDocs = docs})
1669 = do { lcls' <- lookupLocatedTopBndrRn lcls
1670 ; let cls' = unLoc lcls'
1671 kvs = [] -- No scoped kind vars except those in
1672 -- kind signatures on the tyvars
1673
1674 -- Tyvars scope over superclass context and method signatures
1675 ; ((tyvars', context', fds', ats'), stuff_fvs)
1676 <- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> do
1677 -- Checks for distinct tyvars
1678 { (context', cxt_fvs) <- rnContext cls_doc context
1679 ; fds' <- rnFds fds
1680 -- The fundeps have no free variables
1681 ; (ats', fv_ats) <- rnATDecls cls' ats
1682 ; let fvs = cxt_fvs `plusFV`
1683 fv_ats
1684 ; return ((tyvars', context', fds', ats'), fvs) }
1685
1686 ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltEqn cls') at_defs
1687
1688 -- No need to check for duplicate associated type decls
1689 -- since that is done by RnNames.extendGlobalRdrEnvRn
1690
1691 -- Check the signatures
1692 -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
1693 ; let sig_rdr_names_w_locs = [op | L _ (ClassOpSig False ops _) <- sigs
1694 , op <- ops]
1695 ; checkDupRdrNames sig_rdr_names_w_locs
1696 -- Typechecker is responsible for checking that we only
1697 -- give default-method bindings for things in this class.
1698 -- The renamer *could* check this for class decls, but can't
1699 -- for instance decls.
1700
1701 -- The newLocals call is tiresome: given a generic class decl
1702 -- class C a where
1703 -- op :: a -> a
1704 -- op {| x+y |} (Inl a) = ...
1705 -- op {| x+y |} (Inr b) = ...
1706 -- op {| a*b |} (a*b) = ...
1707 -- we want to name both "x" tyvars with the same unique, so that they are
1708 -- easy to group together in the typechecker.
1709 ; (mbinds', sigs', meth_fvs)
1710 <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs
1711 -- No need to check for duplicate method signatures
1712 -- since that is done by RnNames.extendGlobalRdrEnvRn
1713 -- and the methods are already in scope
1714
1715 -- Haddock docs
1716 ; docs' <- mapM (wrapLocM rnDocDecl) docs
1717
1718 ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs
1719 ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',
1720 tcdTyVars = tyvars', tcdFixity = fixity,
1721 tcdFDs = fds', tcdSigs = sigs',
1722 tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
1723 tcdDocs = docs', tcdFVs = all_fvs },
1724 all_fvs ) }
1725 where
1726 cls_doc = ClassDeclCtx lcls
1727
1728 -- "type" and "type instance" declarations
1729 rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
1730 rnTySyn doc rhs = rnLHsType doc rhs
1731
1732 rnDataDefn :: HsDocContext -> HsDataDefn GhcPs
1733 -> RnM (HsDataDefn GhcRn, FreeVars)
1734 rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1735 , dd_ctxt = context, dd_cons = condecls
1736 , dd_kindSig = m_sig, dd_derivs = derivs })
1737 = do { checkTc (h98_style || null (unLoc context))
1738 (badGadtStupidTheta doc)
1739
1740 ; (m_sig', sig_fvs) <- case m_sig of
1741 Just sig -> first Just <$> rnLHsKind doc sig
1742 Nothing -> return (Nothing, emptyFVs)
1743 ; (context', fvs1) <- rnContext doc context
1744 ; (derivs', fvs3) <- rn_derivs derivs
1745
1746 -- For the constructor declarations, drop the LocalRdrEnv
1747 -- in the GADT case, where the type variables in the declaration
1748 -- do not scope over the constructor signatures
1749 -- data T a where { T1 :: forall b. b-> b }
1750 ; let { zap_lcl_env | h98_style = \ thing -> thing
1751 | otherwise = setLocalRdrEnv emptyLocalRdrEnv }
1752 ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls
1753 -- No need to check for duplicate constructor decls
1754 -- since that is done by RnNames.extendGlobalRdrEnvRn
1755
1756 ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
1757 con_fvs `plusFV` sig_fvs
1758 ; return ( HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1759 , dd_ctxt = context', dd_kindSig = m_sig'
1760 , dd_cons = condecls'
1761 , dd_derivs = derivs' }
1762 , all_fvs )
1763 }
1764 where
1765 h98_style = case condecls of -- Note [Stupid theta]
1766 L _ (ConDeclGADT {}) : _ -> False
1767 _ -> True
1768
1769 rn_derivs (L loc ds)
1770 = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies
1771 ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok)
1772 multipleDerivClausesErr
1773 ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause deriv_strats_ok doc) ds
1774 ; return (L loc ds', fvs) }
1775
1776 rnLHsDerivingClause :: Bool -> HsDocContext -> LHsDerivingClause GhcPs
1777 -> RnM (LHsDerivingClause GhcRn, FreeVars)
1778 rnLHsDerivingClause deriv_strats_ok doc
1779 (L loc (HsDerivingClause { deriv_clause_strategy = dcs
1780 , deriv_clause_tys = L loc' dct }))
1781 = do { failIfTc (isJust dcs && not deriv_strats_ok) $
1782 illegalDerivStrategyErr $ fmap unLoc dcs
1783 ; (dct', fvs) <- mapFvRn (rnHsSigType doc) dct
1784 ; return ( L loc (HsDerivingClause { deriv_clause_strategy = dcs
1785 , deriv_clause_tys = L loc' dct' })
1786 , fvs ) }
1787
1788 badGadtStupidTheta :: HsDocContext -> SDoc
1789 badGadtStupidTheta _
1790 = vcat [text "No context is allowed on a GADT-style data declaration",
1791 text "(You can put a context on each constructor, though.)"]
1792
1793 illegalDerivStrategyErr :: Maybe DerivStrategy -> SDoc
1794 illegalDerivStrategyErr ds
1795 = vcat [ text "Illegal deriving strategy" <> colon <+> maybe empty ppr ds
1796 , text "Use DerivingStrategies to enable this extension" ]
1797
1798 multipleDerivClausesErr :: SDoc
1799 multipleDerivClausesErr
1800 = vcat [ text "Illegal use of multiple, consecutive deriving clauses"
1801 , text "Use DerivingStrategies to allow this" ]
1802
1803 rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested
1804 -- inside an *class decl* for cls
1805 -- used for associated types
1806 -> FamilyDecl GhcPs
1807 -> RnM (FamilyDecl GhcRn, FreeVars)
1808 rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
1809 , fdFixity = fixity
1810 , fdInfo = info, fdResultSig = res_sig
1811 , fdInjectivityAnn = injectivity })
1812 = do { tycon' <- lookupLocatedTopBndrRn tycon
1813 ; kvs <- extractRdrKindSigVars res_sig
1814 ; ((tyvars', res_sig', injectivity'), fv1) <-
1815 bindHsQTyVars doc Nothing mb_cls kvs tyvars $ \ tyvars' _ ->
1816 do { let rn_sig = rnFamResultSig doc
1817 ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig
1818 ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
1819 injectivity
1820 ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }
1821 ; (info', fv2) <- rn_info info
1822 ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars'
1823 , fdFixity = fixity
1824 , fdInfo = info', fdResultSig = res_sig'
1825 , fdInjectivityAnn = injectivity' }
1826 , fv1 `plusFV` fv2) }
1827 where
1828 doc = TyFamilyCtx tycon
1829
1830 ----------------------
1831 rn_info (ClosedTypeFamily (Just eqns))
1832 = do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns
1833 -- no class context,
1834 ; return (ClosedTypeFamily (Just eqns'), fvs) }
1835 rn_info (ClosedTypeFamily Nothing)
1836 = return (ClosedTypeFamily Nothing, emptyFVs)
1837 rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
1838 rn_info DataFamily = return (DataFamily, emptyFVs)
1839
1840 rnFamResultSig :: HsDocContext
1841 -> FamilyResultSig GhcPs
1842 -> RnM (FamilyResultSig GhcRn, FreeVars)
1843 rnFamResultSig _ NoSig
1844 = return (NoSig, emptyFVs)
1845 rnFamResultSig doc (KindSig kind)
1846 = do { (rndKind, ftvs) <- rnLHsKind doc kind
1847 ; return (KindSig rndKind, ftvs) }
1848 rnFamResultSig doc (TyVarSig tvbndr)
1849 = do { -- `TyVarSig` tells us that user named the result of a type family by
1850 -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to
1851 -- be sure that the supplied result name is not identical to an
1852 -- already in-scope type variable from an enclosing class.
1853 --
1854 -- Example of disallowed declaration:
1855 -- class C a b where
1856 -- type F b = a | a -> b
1857 rdr_env <- getLocalRdrEnv
1858 ; let resName = hsLTyVarName tvbndr
1859 ; when (resName `elemLocalRdrEnv` rdr_env) $
1860 addErrAt (getLoc tvbndr) $
1861 (hsep [ text "Type variable", quotes (ppr resName) <> comma
1862 , text "naming a type family result,"
1863 ] $$
1864 text "shadows an already bound type variable")
1865
1866 ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for
1867 -- scoping checks that are irrelevant here
1868 tvbndr $ \ tvbndr' ->
1869 return (TyVarSig tvbndr', unitFV (hsLTyVarName tvbndr')) }
1870
1871 -- Note [Renaming injectivity annotation]
1872 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1873 --
1874 -- During renaming of injectivity annotation we have to make several checks to
1875 -- make sure that it is well-formed. At the moment injectivity annotation
1876 -- consists of a single injectivity condition, so the terms "injectivity
1877 -- annotation" and "injectivity condition" might be used interchangeably. See
1878 -- Note [Injectivity annotation] for a detailed discussion of currently allowed
1879 -- injectivity annotations.
1880 --
1881 -- Checking LHS is simple because the only type variable allowed on the LHS of
1882 -- injectivity condition is the variable naming the result in type family head.
1883 -- Example of disallowed annotation:
1884 --
1885 -- type family Foo a b = r | b -> a
1886 --
1887 -- Verifying RHS of injectivity consists of checking that:
1888 --
1889 -- 1. only variables defined in type family head appear on the RHS (kind
1890 -- variables are also allowed). Example of disallowed annotation:
1891 --
1892 -- type family Foo a = r | r -> b
1893 --
1894 -- 2. for associated types the result variable does not shadow any of type
1895 -- class variables. Example of disallowed annotation:
1896 --
1897 -- class Foo a b where
1898 -- type F a = b | b -> a
1899 --
1900 -- Breaking any of these assumptions results in an error.
1901
1902 -- | Rename injectivity annotation. Note that injectivity annotation is just the
1903 -- part after the "|". Everything that appears before it is renamed in
1904 -- rnFamDecl.
1905 rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in
1906 -- type family head
1907 -> LFamilyResultSig GhcRn -- ^ Result signature
1908 -> LInjectivityAnn GhcPs -- ^ Injectivity annotation
1909 -> RnM (LInjectivityAnn GhcRn)
1910 rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv))
1911 (L srcSpan (InjectivityAnn injFrom injTo))
1912 = do
1913 { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors)
1914 <- askNoErrs $
1915 bindLocalNames [hsLTyVarName resTv] $
1916 -- The return type variable scopes over the injectivity annotation
1917 -- e.g. type family F a = (r::*) | r -> a
1918 do { injFrom' <- rnLTyVar injFrom
1919 ; injTo' <- mapM rnLTyVar injTo
1920 ; return $ L srcSpan (InjectivityAnn injFrom' injTo') }
1921
1922 ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs
1923 resName = hsLTyVarName resTv
1924 -- See Note [Renaming injectivity annotation]
1925 lhsValid = EQ == (stableNameCmp resName (unLoc injFrom'))
1926 rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames
1927
1928 -- if renaming of type variables ended with errors (eg. there were
1929 -- not-in-scope variables) don't check the validity of injectivity
1930 -- annotation. This gives better error messages.
1931 ; when (noRnErrors && not lhsValid) $
1932 addErrAt (getLoc injFrom)
1933 ( vcat [ text $ "Incorrect type variable on the LHS of "
1934 ++ "injectivity condition"
1935 , nest 5
1936 ( vcat [ text "Expected :" <+> ppr resName
1937 , text "Actual :" <+> ppr injFrom ])])
1938
1939 ; when (noRnErrors && not (Set.null rhsValid)) $
1940 do { let errorVars = Set.toList rhsValid
1941 ; addErrAt srcSpan $ ( hsep
1942 [ text "Unknown type variable" <> plural errorVars
1943 , text "on the RHS of injectivity condition:"
1944 , interpp'SP errorVars ] ) }
1945
1946 ; return injDecl' }
1947
1948 -- We can only hit this case when the user writes injectivity annotation without
1949 -- naming the result:
1950 --
1951 -- type family F a | result -> a
1952 -- type family F a :: * | result -> a
1953 --
1954 -- So we rename injectivity annotation like we normally would except that
1955 -- this time we expect "result" to be reported not in scope by rnLTyVar.
1956 rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) =
1957 setSrcSpan srcSpan $ do
1958 (injDecl', _) <- askNoErrs $ do
1959 injFrom' <- rnLTyVar injFrom
1960 injTo' <- mapM rnLTyVar injTo
1961 return $ L srcSpan (InjectivityAnn injFrom' injTo')
1962 return $ injDecl'
1963
1964 {-
1965 Note [Stupid theta]
1966 ~~~~~~~~~~~~~~~~~~~
1967 Trac #3850 complains about a regression wrt 6.10 for
1968 data Show a => T a
1969 There is no reason not to allow the stupid theta if there are no data
1970 constructors. It's still stupid, but does no harm, and I don't want
1971 to cause programs to break unnecessarily (notably HList). So if there
1972 are no data constructors we allow h98_style = True
1973 -}
1974
1975
1976 {- *****************************************************
1977 * *
1978 Support code for type/data declarations
1979 * *
1980 ***************************************************** -}
1981
1982 ---------------
1983 badAssocRhs :: [Name] -> RnM ()
1984 badAssocRhs ns
1985 = addErr (hang (text "The RHS of an associated type declaration mentions"
1986 <+> text "out-of-scope variable" <> plural ns
1987 <+> pprWithCommas (quotes . ppr) ns)
1988 2 (text "All such variables must be bound on the LHS"))
1989
1990 -----------------
1991 rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)
1992 rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
1993
1994 rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
1995 rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
1996 , con_cxt = mcxt, con_details = details
1997 , con_doc = mb_doc })
1998 = do { _ <- addLocM checkConName name
1999 ; new_name <- lookupLocatedTopBndrRn name
2000 ; mb_doc' <- rnMbLHsDoc mb_doc
2001
2002 ; let doc = ConDeclCtx [new_name]
2003 qtvs' = qtvs `orElse` mkHsQTvs []
2004 body_kvs = [] -- Consider data T a = forall (b::k). MkT (...)
2005 -- The 'k' will already be in scope from the
2006 -- bindHsQTyVars for the entire DataDecl
2007 -- So there can be no new body_kvs here
2008 ; bindHsQTyVars doc (Just $ inHsDocContext doc) Nothing body_kvs qtvs' $
2009 \new_tyvars _ -> do
2010 { (new_context, fvs1) <- case mcxt of
2011 Nothing -> return (Nothing,emptyFVs)
2012 Just lcxt -> do { (lctx',fvs) <- rnContext doc lcxt
2013 ; return (Just lctx',fvs) }
2014 ; (new_details, fvs2) <- rnConDeclDetails (unLoc new_name) doc details
2015 ; let (new_details',fvs3) = (new_details,emptyFVs)
2016 ; traceRn "rnConDecl" (ppr name <+> vcat
2017 [ text "qtvs:" <+> ppr qtvs
2018 , text "qtvs':" <+> ppr qtvs' ])
2019 ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
2020 new_tyvars' = case qtvs of
2021 Nothing -> Nothing
2022 Just _ -> Just new_tyvars
2023 ; return (decl { con_name = new_name, con_qvars = new_tyvars'
2024 , con_cxt = new_context, con_details = new_details'
2025 , con_doc = mb_doc' },
2026 all_fvs) }}
2027
2028 rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty
2029 , con_doc = mb_doc })
2030 = do { mapM_ (addLocM checkConName) names
2031 ; new_names <- mapM lookupLocatedTopBndrRn names
2032 ; let doc = ConDeclCtx new_names
2033 ; mb_doc' <- rnMbLHsDoc mb_doc
2034
2035 ; (ty', fvs) <- rnHsSigType doc ty
2036 ; traceRn "rnConDecl" (ppr names <+> vcat
2037 [ text "fvs:" <+> ppr fvs ])
2038 ; return (decl { con_names = new_names, con_type = ty'
2039 , con_doc = mb_doc' },
2040 fvs) }
2041
2042 rnConDeclDetails
2043 :: Name
2044 -> HsDocContext
2045 -> HsConDetails (LHsType GhcPs) (Located [LConDeclField GhcPs])
2046 -> RnM (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),
2047 FreeVars)
2048 rnConDeclDetails _ doc (PrefixCon tys)
2049 = do { (new_tys, fvs) <- rnLHsTypes doc tys
2050 ; return (PrefixCon new_tys, fvs) }
2051
2052 rnConDeclDetails _ doc (InfixCon ty1 ty2)
2053 = do { (new_ty1, fvs1) <- rnLHsType doc ty1
2054 ; (new_ty2, fvs2) <- rnLHsType doc ty2
2055 ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
2056
2057 rnConDeclDetails con doc (RecCon (L l fields))
2058 = do { fls <- lookupConstructorFields con
2059 ; (new_fields, fvs) <- rnConDeclFields doc fls fields
2060 -- No need to check for duplicate fields
2061 -- since that is done by RnNames.extendGlobalRdrEnvRn
2062 ; return (RecCon (L l new_fields), fvs) }
2063
2064 -------------------------------------------------
2065
2066 -- | Brings pattern synonym names and also pattern synonym selectors
2067 -- from record pattern synonyms into scope.
2068 extendPatSynEnv :: HsValBinds GhcPs -> MiniFixityEnv
2069 -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a
2070 extendPatSynEnv val_decls local_fix_env thing = do {
2071 names_with_fls <- new_ps val_decls
2072 ; let pat_syn_bndrs = concat [ name: map flSelector fields
2073 | (name, fields) <- names_with_fls ]
2074 ; let avails = map avail pat_syn_bndrs
2075 ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env
2076
2077 ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls
2078 final_gbl_env = gbl_env { tcg_field_env = field_env' }
2079 ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }
2080 where
2081 new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]
2082 new_ps (ValBindsIn binds _) = foldrBagM new_ps' [] binds
2083 new_ps _ = panic "new_ps"
2084
2085 new_ps' :: LHsBindLR GhcPs GhcPs
2086 -> [(Name, [FieldLabel])]
2087 -> TcM [(Name, [FieldLabel])]
2088 new_ps' bind names
2089 | L bind_loc (PatSynBind (PSB { psb_id = L _ n
2090 , psb_args = RecordPatSyn as })) <- bind
2091 = do
2092 bnd_name <- newTopSrcBinder (L bind_loc n)
2093 let rnames = map recordPatSynSelectorId as
2094 mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs
2095 mkFieldOcc (L l name) = L l (FieldOcc (L l name) PlaceHolder)
2096 field_occs = map mkFieldOcc rnames
2097 flds <- mapM (newRecordSelector False [bnd_name]) field_occs
2098 return ((bnd_name, flds): names)
2099 | L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind
2100 = do
2101 bnd_name <- newTopSrcBinder (L bind_loc n)
2102 return ((bnd_name, []): names)
2103 | otherwise
2104 = return names
2105
2106 {-
2107 *********************************************************
2108 * *
2109 \subsection{Support code to rename types}
2110 * *
2111 *********************************************************
2112 -}
2113
2114 rnFds :: [Located (FunDep (Located RdrName))]
2115 -> RnM [Located (FunDep (Located Name))]
2116 rnFds fds
2117 = mapM (wrapLocM rn_fds) fds
2118 where
2119 rn_fds (tys1, tys2)
2120 = do { tys1' <- rnHsTyVars tys1
2121 ; tys2' <- rnHsTyVars tys2
2122 ; return (tys1', tys2') }
2123
2124 rnHsTyVars :: [Located RdrName] -> RnM [Located Name]
2125 rnHsTyVars tvs = mapM rnHsTyVar tvs
2126
2127 rnHsTyVar :: Located RdrName -> RnM (Located Name)
2128 rnHsTyVar (L l tyvar) = do
2129 tyvar' <- lookupOccRn tyvar
2130 return (L l tyvar')
2131
2132 {-
2133 *********************************************************
2134 * *
2135 findSplice
2136 * *
2137 *********************************************************
2138
2139 This code marches down the declarations, looking for the first
2140 Template Haskell splice. As it does so it
2141 a) groups the declarations into a HsGroup
2142 b) runs any top-level quasi-quotes
2143 -}
2144
2145 findSplice :: [LHsDecl GhcPs]
2146 -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
2147 findSplice ds = addl emptyRdrGroup ds
2148
2149 addl :: HsGroup GhcPs -> [LHsDecl GhcPs]
2150 -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
2151 -- This stuff reverses the declarations (again) but it doesn't matter
2152 addl gp [] = return (gp, Nothing)
2153 addl gp (L l d : ds) = add gp l d ds
2154
2155
2156 add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs]
2157 -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
2158
2159 -- #10047: Declaration QuasiQuoters are expanded immediately, without
2160 -- causing a group split
2161 add gp _ (SpliceD (SpliceDecl (L _ qq@HsQuasiQuote{}) _)) ds
2162 = do { (ds', _) <- rnTopSpliceDecls qq
2163 ; addl gp (ds' ++ ds)
2164 }
2165
2166 add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
2167 = do { -- We've found a top-level splice. If it is an *implicit* one
2168 -- (i.e. a naked top level expression)
2169 case flag of
2170 ExplicitSplice -> return ()
2171 ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell
2172 ; unless th_on $ setSrcSpan loc $
2173 failWith badImplicitSplice }
2174
2175 ; return (gp, Just (splice, ds)) }
2176 where
2177 badImplicitSplice = text "Parse error: module header, import declaration"
2178 $$ text "or top-level declaration expected."
2179
2180 -- Class declarations: pull out the fixity signatures to the top
2181 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
2182 | isClassDecl d
2183 = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
2184 addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
2185 | otherwise
2186 = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
2187
2188 -- Signatures: fixity sigs go a different place than all others
2189 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
2190 = addl (gp {hs_fixds = L l f : ts}) ds
2191 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
2192 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
2193
2194 -- Value declarations: use add_bind
2195 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
2196 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
2197
2198 -- Role annotations: added to the TyClGroup
2199 add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD d) ds
2200 = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds
2201
2202 -- NB instance declarations go into TyClGroups. We throw them into the first
2203 -- group, just as we do for the TyClD case. The renamer will go on to group
2204 -- and order them later.
2205 add gp@(HsGroup {hs_tyclds = ts}) l (InstD d) ds
2206 = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds
2207
2208 -- The rest are routine
2209 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
2210 = addl (gp { hs_derivds = L l d : ts }) ds
2211 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
2212 = addl (gp { hs_defds = L l d : ts }) ds
2213 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
2214 = addl (gp { hs_fords = L l d : ts }) ds
2215 add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
2216 = addl (gp { hs_warnds = L l d : ts }) ds
2217 add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
2218 = addl (gp { hs_annds = L l d : ts }) ds
2219 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
2220 = addl (gp { hs_ruleds = L l d : ts }) ds
2221 add gp@(HsGroup {hs_vects = ts}) l (VectD d) ds
2222 = addl (gp { hs_vects = L l d : ts }) ds
2223 add gp l (DocD d) ds
2224 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
2225
2226 add_tycld :: LTyClDecl a -> [TyClGroup a] -> [TyClGroup a]
2227 add_tycld d [] = [TyClGroup { group_tyclds = [d]
2228 , group_roles = []
2229 , group_instds = []
2230 }
2231 ]
2232 add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
2233 = ds { group_tyclds = d : tyclds } : dss
2234
2235 add_instd :: LInstDecl a -> [TyClGroup a] -> [TyClGroup a]
2236 add_instd d [] = [TyClGroup { group_tyclds = []
2237 , group_roles = []
2238 , group_instds = [d]
2239 }
2240 ]
2241 add_instd d (ds@(TyClGroup { group_instds = instds }):dss)
2242 = ds { group_instds = d : instds } : dss
2243
2244 add_role_annot :: LRoleAnnotDecl a -> [TyClGroup a] -> [TyClGroup a]
2245 add_role_annot d [] = [TyClGroup { group_tyclds = []
2246 , group_roles = [d]
2247 , group_instds = []
2248 }
2249 ]
2250 add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
2251 = tycls { group_roles = d : roles } : rest
2252
2253 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
2254 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
2255 add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
2256
2257 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
2258 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
2259 add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"