Rename SigTv to TyVarTv (#15480)
[ghc.git] / compiler / rename / RnBinds.hs
1 {-# LANGUAGE ScopedTypeVariables, BangPatterns #-}
2 {-# LANGUAGE TypeFamilies #-}
3
4 {-
5 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6
7 \section[RnBinds]{Renaming and dependency analysis of bindings}
8
9 This module does renaming and dependency analysis on value bindings in
10 the abstract syntax. It does {\em not} do cycle-checks on class or
11 type-synonym declarations; those cannot be done at this stage because
12 they may be affected by renaming (which isn't fully worked out yet).
13 -}
14
15 module RnBinds (
16 -- Renaming top-level bindings
17 rnTopBindsLHS, rnTopBindsBoot, rnValBindsRHS,
18
19 -- Renaming local bindings
20 rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
21
22 -- Other bindings
23 rnMethodBinds, renameSigs,
24 rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl,
25 makeMiniFixityEnv, MiniFixityEnv,
26 HsSigCtxt(..)
27 ) where
28
29 import GhcPrelude
30
31 import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
32
33 import HsSyn
34 import TcRnMonad
35 import RnTypes
36 import RnPat
37 import RnNames
38 import RnEnv
39 import RnFixity
40 import RnUtils ( HsDocContext(..), mapFvRn, extendTyVarEnvFVRn
41 , checkDupRdrNames, warnUnusedLocalBinds
42 , checkDupAndShadowedNames, bindLocalNamesFV )
43 import DynFlags
44 import Module
45 import Name
46 import NameEnv
47 import NameSet
48 import RdrName ( RdrName, rdrNameOcc )
49 import SrcLoc
50 import ListSetOps ( findDupsEq )
51 import BasicTypes ( RecFlag(..) )
52 import Digraph ( SCC(..) )
53 import Bag
54 import Util
55 import Outputable
56 import UniqSet
57 import Maybes ( orElse )
58 import qualified GHC.LanguageExtensions as LangExt
59
60 import Control.Monad
61 import Data.Foldable ( toList )
62 import Data.List ( partition, sort )
63 import Data.List.NonEmpty ( NonEmpty(..) )
64
65 {-
66 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
67 -- place and can be used when complaining.
68
69 The code tree received by the function @rnBinds@ contains definitions
70 in where-clauses which are all apparently mutually recursive, but which may
71 not really depend upon each other. For example, in the top level program
72 \begin{verbatim}
73 f x = y where a = x
74 y = x
75 \end{verbatim}
76 the definitions of @a@ and @y@ do not depend on each other at all.
77 Unfortunately, the typechecker cannot always check such definitions.
78 \footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
79 definitions. In Proceedings of the International Symposium on Programming,
80 Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
81 However, the typechecker usually can check definitions in which only the
82 strongly connected components have been collected into recursive bindings.
83 This is precisely what the function @rnBinds@ does.
84
85 ToDo: deal with case where a single monobinds binds the same variable
86 twice.
87
88 The vertag tag is a unique @Int@; the tags only need to be unique
89 within one @MonoBinds@, so that unique-Int plumbing is done explicitly
90 (heavy monad machinery not needed).
91
92
93 ************************************************************************
94 * *
95 * naming conventions *
96 * *
97 ************************************************************************
98
99 \subsection[name-conventions]{Name conventions}
100
101 The basic algorithm involves walking over the tree and returning a tuple
102 containing the new tree plus its free variables. Some functions, such
103 as those walking polymorphic bindings (HsBinds) and qualifier lists in
104 list comprehensions (@Quals@), return the variables bound in local
105 environments. These are then used to calculate the free variables of the
106 expression evaluated in these environments.
107
108 Conventions for variable names are as follows:
109 \begin{itemize}
110 \item
111 new code is given a prime to distinguish it from the old.
112
113 \item
114 a set of variables defined in @Exp@ is written @dvExp@
115
116 \item
117 a set of variables free in @Exp@ is written @fvExp@
118 \end{itemize}
119
120 ************************************************************************
121 * *
122 * analysing polymorphic bindings (HsBindGroup, HsBind)
123 * *
124 ************************************************************************
125
126 \subsubsection[dep-HsBinds]{Polymorphic bindings}
127
128 Non-recursive expressions are reconstructed without any changes at top
129 level, although their component expressions may have to be altered.
130 However, non-recursive expressions are currently not expected as
131 \Haskell{} programs, and this code should not be executed.
132
133 Monomorphic bindings contain information that is returned in a tuple
134 (a @FlatMonoBinds@) containing:
135
136 \begin{enumerate}
137 \item
138 a unique @Int@ that serves as the ``vertex tag'' for this binding.
139
140 \item
141 the name of a function or the names in a pattern. These are a set
142 referred to as @dvLhs@, the defined variables of the left hand side.
143
144 \item
145 the free variables of the body. These are referred to as @fvBody@.
146
147 \item
148 the definition's actual code. This is referred to as just @code@.
149 \end{enumerate}
150
151 The function @nonRecDvFv@ returns two sets of variables. The first is
152 the set of variables defined in the set of monomorphic bindings, while the
153 second is the set of free variables in those bindings.
154
155 The set of variables defined in a non-recursive binding is just the
156 union of all of them, as @union@ removes duplicates. However, the
157 free variables in each successive set of cumulative bindings is the
158 union of those in the previous set plus those of the newest binding after
159 the defined variables of the previous set have been removed.
160
161 @rnMethodBinds@ deals only with the declarations in class and
162 instance declarations. It expects only to see @FunMonoBind@s, and
163 it expects the global environment to contain bindings for the binders
164 (which are all class operations).
165
166 ************************************************************************
167 * *
168 \subsubsection{ Top-level bindings}
169 * *
170 ************************************************************************
171 -}
172
173 -- for top-level bindings, we need to make top-level names,
174 -- so we have a different entry point than for local bindings
175 rnTopBindsLHS :: MiniFixityEnv
176 -> HsValBinds GhcPs
177 -> RnM (HsValBindsLR GhcRn GhcPs)
178 rnTopBindsLHS fix_env binds
179 = rnValBindsLHS (topRecNameMaker fix_env) binds
180
181 rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs
182 -> RnM (HsValBinds GhcRn, DefUses)
183 -- A hs-boot file has no bindings.
184 -- Return a single HsBindGroup with empty binds and renamed signatures
185 rnTopBindsBoot bound_names (ValBinds _ mbinds sigs)
186 = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
187 ; (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs
188 ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) }
189 rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b)
190
191 {-
192 *********************************************************
193 * *
194 HsLocalBinds
195 * *
196 *********************************************************
197 -}
198
199 rnLocalBindsAndThen :: HsLocalBinds GhcPs
200 -> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
201 -> RnM (result, FreeVars)
202 -- This version (a) assumes that the binding vars are *not* already in scope
203 -- (b) removes the binders from the free vars of the thing inside
204 -- The parser doesn't produce ThenBinds
205 rnLocalBindsAndThen (EmptyLocalBinds x) thing_inside =
206 thing_inside (EmptyLocalBinds x) emptyNameSet
207
208 rnLocalBindsAndThen (HsValBinds x val_binds) thing_inside
209 = rnLocalValBindsAndThen val_binds $ \ val_binds' ->
210 thing_inside (HsValBinds x val_binds')
211
212 rnLocalBindsAndThen (HsIPBinds x binds) thing_inside = do
213 (binds',fv_binds) <- rnIPBinds binds
214 (thing, fvs_thing) <- thing_inside (HsIPBinds x binds') fv_binds
215 return (thing, fvs_thing `plusFV` fv_binds)
216
217 rnLocalBindsAndThen (XHsLocalBindsLR _) _ = panic "rnLocalBindsAndThen"
218
219 rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars)
220 rnIPBinds (IPBinds _ ip_binds ) = do
221 (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds
222 return (IPBinds noExt ip_binds', plusFVs fvs_s)
223 rnIPBinds (XHsIPBinds _) = panic "rnIPBinds"
224
225 rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars)
226 rnIPBind (IPBind _ ~(Left n) expr) = do
227 (expr',fvExpr) <- rnLExpr expr
228 return (IPBind noExt (Left n) expr', fvExpr)
229 rnIPBind (XIPBind _) = panic "rnIPBind"
230
231 {-
232 ************************************************************************
233 * *
234 ValBinds
235 * *
236 ************************************************************************
237 -}
238
239 -- Renaming local binding groups
240 -- Does duplicate/shadow check
241 rnLocalValBindsLHS :: MiniFixityEnv
242 -> HsValBinds GhcPs
243 -> RnM ([Name], HsValBindsLR GhcRn GhcPs)
244 rnLocalValBindsLHS fix_env binds
245 = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds
246
247 -- Check for duplicates and shadowing
248 -- Must do this *after* renaming the patterns
249 -- See Note [Collect binders only after renaming] in HsUtils
250
251 -- We need to check for dups here because we
252 -- don't don't bind all of the variables from the ValBinds at once
253 -- with bindLocatedLocals any more.
254 --
255 -- Note that we don't want to do this at the top level, since
256 -- sorting out duplicates and shadowing there happens elsewhere.
257 -- The behavior is even different. For example,
258 -- import A(f)
259 -- f = ...
260 -- should not produce a shadowing warning (but it will produce
261 -- an ambiguity warning if you use f), but
262 -- import A(f)
263 -- g = let f = ... in f
264 -- should.
265 ; let bound_names = collectHsValBinders binds'
266 -- There should be only Ids, but if there are any bogus
267 -- pattern synonyms, we'll collect them anyway, so that
268 -- we don't generate subsequent out-of-scope messages
269 ; envs <- getRdrEnvs
270 ; checkDupAndShadowedNames envs bound_names
271
272 ; return (bound_names, binds') }
273
274 -- renames the left-hand sides
275 -- generic version used both at the top level and for local binds
276 -- does some error checking, but not what gets done elsewhere at the top level
277 rnValBindsLHS :: NameMaker
278 -> HsValBinds GhcPs
279 -> RnM (HsValBindsLR GhcRn GhcPs)
280 rnValBindsLHS topP (ValBinds x mbinds sigs)
281 = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds
282 ; return $ ValBinds x mbinds' sigs }
283 where
284 bndrs = collectHsBindsBinders mbinds
285 doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs
286
287 rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)
288
289 -- General version used both from the top-level and for local things
290 -- Assumes the LHS vars are in scope
291 --
292 -- Does not bind the local fixity declarations
293 rnValBindsRHS :: HsSigCtxt
294 -> HsValBindsLR GhcRn GhcPs
295 -> RnM (HsValBinds GhcRn, DefUses)
296
297 rnValBindsRHS ctxt (ValBinds _ mbinds sigs)
298 = do { (sigs', sig_fvs) <- renameSigs ctxt sigs
299 ; binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn sigs')) mbinds
300 ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus
301
302 ; let patsyn_fvs = foldr (unionNameSet . psb_ext) emptyNameSet $
303 getPatSynBinds anal_binds
304 -- The uses in binds_w_dus for PatSynBinds do not include
305 -- variables used in the patsyn builders; see
306 -- Note [Pattern synonym builders don't yield dependencies]
307 -- But psb_fvs /does/ include those builder fvs. So we
308 -- add them back in here to avoid bogus warnings about
309 -- unused variables (Trac #12548)
310
311 valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs
312 `plusDU` usesOnly patsyn_fvs
313 -- Put the sig uses *after* the bindings
314 -- so that the binders are removed from
315 -- the uses in the sigs
316
317 ; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) }
318
319 rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b)
320
321 -- Wrapper for local binds
322 --
323 -- The *client* of this function is responsible for checking for unused binders;
324 -- it doesn't (and can't: we don't have the thing inside the binds) happen here
325 --
326 -- The client is also responsible for bringing the fixities into scope
327 rnLocalValBindsRHS :: NameSet -- names bound by the LHSes
328 -> HsValBindsLR GhcRn GhcPs
329 -> RnM (HsValBinds GhcRn, DefUses)
330 rnLocalValBindsRHS bound_names binds
331 = rnValBindsRHS (LocalBindCtxt bound_names) binds
332
333 -- for local binds
334 -- wrapper that does both the left- and right-hand sides
335 --
336 -- here there are no local fixity decls passed in;
337 -- the local fixity decls come from the ValBinds sigs
338 rnLocalValBindsAndThen
339 :: HsValBinds GhcPs
340 -> (HsValBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
341 -> RnM (result, FreeVars)
342 rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside
343 = do { -- (A) Create the local fixity environment
344 new_fixities <- makeMiniFixityEnv [ L loc sig
345 | L loc (FixSig _ sig) <- sigs]
346
347 -- (B) Rename the LHSes
348 ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds
349
350 -- ...and bring them (and their fixities) into scope
351 ; bindLocalNamesFV bound_names $
352 addLocalFixities new_fixities bound_names $ do
353
354 { -- (C) Do the RHS and thing inside
355 (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs
356 ; (result, result_fvs) <- thing_inside binds' (allUses dus)
357
358 -- Report unused bindings based on the (accurate)
359 -- findUses. E.g.
360 -- let x = x in 3
361 -- should report 'x' unused
362 ; let real_uses = findUses dus result_fvs
363 -- Insert fake uses for variables introduced implicitly by
364 -- wildcards (#4404)
365 implicit_uses = hsValBindsImplicits binds'
366 ; warnUnusedLocalBinds bound_names
367 (real_uses `unionNameSet` implicit_uses)
368
369 ; let
370 -- The variables "used" in the val binds are:
371 -- (1) the uses of the binds (allUses)
372 -- (2) the FVs of the thing-inside
373 all_uses = allUses dus `plusFV` result_fvs
374 -- Note [Unused binding hack]
375 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~
376 -- Note that *in contrast* to the above reporting of
377 -- unused bindings, (1) above uses duUses to return *all*
378 -- the uses, even if the binding is unused. Otherwise consider:
379 -- x = 3
380 -- y = let p = x in 'x' -- NB: p not used
381 -- If we don't "see" the dependency of 'y' on 'x', we may put the
382 -- bindings in the wrong order, and the type checker will complain
383 -- that x isn't in scope
384 --
385 -- But note that this means we won't report 'x' as unused,
386 -- whereas we would if we had { x = 3; p = x; y = 'x' }
387
388 ; return (result, all_uses) }}
389 -- The bound names are pruned out of all_uses
390 -- by the bindLocalNamesFV call above
391
392 rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs)
393
394
395 ---------------------
396
397 -- renaming a single bind
398
399 rnBindLHS :: NameMaker
400 -> SDoc
401 -> HsBind GhcPs
402 -- returns the renamed left-hand side,
403 -- and the FreeVars *of the LHS*
404 -- (i.e., any free variables of the pattern)
405 -> RnM (HsBindLR GhcRn GhcPs)
406
407 rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat })
408 = do
409 -- we don't actually use the FV processing of rnPatsAndThen here
410 (pat',pat'_fvs) <- rnBindPat name_maker pat
411 return (bind { pat_lhs = pat', pat_ext = pat'_fvs })
412 -- We temporarily store the pat's FVs in bind_fvs;
413 -- gets updated to the FVs of the whole bind
414 -- when doing the RHS below
415
416 rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name })
417 = do { name <- applyNameMaker name_maker rdr_name
418 ; return (bind { fun_id = name
419 , fun_ext = noExt }) }
420
421 rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname })
422 | isTopRecNameMaker name_maker
423 = do { addLocM checkConName rdrname
424 ; name <- lookupLocatedTopBndrRn rdrname -- Should be in scope already
425 ; return (PatSynBind x psb{ psb_ext = noExt, psb_id = name }) }
426
427 | otherwise -- Pattern synonym, not at top level
428 = do { addErr localPatternSynonymErr -- Complain, but make up a fake
429 -- name so that we can carry on
430 ; name <- applyNameMaker name_maker rdrname
431 ; return (PatSynBind x psb{ psb_ext = noExt, psb_id = name }) }
432 where
433 localPatternSynonymErr :: SDoc
434 localPatternSynonymErr
435 = hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname))
436 2 (text "Pattern synonym declarations are only valid at top level")
437
438 rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b)
439
440 rnLBind :: (Name -> [Name]) -- Signature tyvar function
441 -> LHsBindLR GhcRn GhcPs
442 -> RnM (LHsBind GhcRn, [Name], Uses)
443 rnLBind sig_fn (L loc bind)
444 = setSrcSpan loc $
445 do { (bind', bndrs, dus) <- rnBind sig_fn bind
446 ; return (L loc bind', bndrs, dus) }
447
448 -- assumes the left-hands-side vars are in scope
449 rnBind :: (Name -> [Name]) -- Signature tyvar function
450 -> HsBindLR GhcRn GhcPs
451 -> RnM (HsBind GhcRn, [Name], Uses)
452 rnBind _ bind@(PatBind { pat_lhs = pat
453 , pat_rhs = grhss
454 -- pat fvs were stored in bind_fvs
455 -- after processing the LHS
456 , pat_ext = pat_fvs })
457 = do { mod <- getModule
458 ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss
459
460 -- No scoped type variables for pattern bindings
461 ; let all_fvs = pat_fvs `plusFV` rhs_fvs
462 fvs' = filterNameSet (nameIsLocalOrFrom mod) all_fvs
463 -- Keep locally-defined Names
464 -- As well as dependency analysis, we need these for the
465 -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
466 bndrs = collectPatBinders pat
467 bind' = bind { pat_rhs = grhss'
468 , pat_ext = fvs' }
469
470 ok_nobind_pat
471 = -- See Note [Pattern bindings that bind no variables]
472 case pat of
473 L _ (WildPat {}) -> True
474 L _ (BangPat {}) -> True -- #9127, #13646
475 L _ (SplicePat {}) -> True
476 _ -> False
477
478 -- Warn if the pattern binds no variables
479 -- See Note [Pattern bindings that bind no variables]
480 ; whenWOptM Opt_WarnUnusedPatternBinds $
481 when (null bndrs && not ok_nobind_pat) $
482 addWarn (Reason Opt_WarnUnusedPatternBinds) $
483 unusedPatBindWarn bind'
484
485 ; fvs' `seq` -- See Note [Free-variable space leak]
486 return (bind', bndrs, all_fvs) }
487
488 rnBind sig_fn bind@(FunBind { fun_id = name
489 , fun_matches = matches })
490 -- invariant: no free vars here when it's a FunBind
491 = do { let plain_name = unLoc name
492
493 ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
494 -- bindSigTyVars tests for LangExt.ScopedTyVars
495 rnMatchGroup (mkPrefixFunRhs name)
496 rnLExpr matches
497 ; let is_infix = isInfixFunBind bind
498 ; when is_infix $ checkPrecMatch plain_name matches'
499
500 ; mod <- getModule
501 ; let fvs' = filterNameSet (nameIsLocalOrFrom mod) rhs_fvs
502 -- Keep locally-defined Names
503 -- As well as dependency analysis, we need these for the
504 -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
505
506 ; fvs' `seq` -- See Note [Free-variable space leak]
507 return (bind { fun_matches = matches'
508 , fun_ext = fvs' },
509 [plain_name], rhs_fvs)
510 }
511
512 rnBind sig_fn (PatSynBind x bind)
513 = do { (bind', name, fvs) <- rnPatSynBind sig_fn bind
514 ; return (PatSynBind x bind', name, fvs) }
515
516 rnBind _ b = pprPanic "rnBind" (ppr b)
517
518 {- Note [Pattern bindings that bind no variables]
519 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
520 Generally, we want to warn about pattern bindings like
521 Just _ = e
522 because they don't do anything! But we have three exceptions:
523
524 * A wildcard pattern
525 _ = rhs
526 which (a) is not that different from _v = rhs
527 (b) is sometimes used to give a type sig for,
528 or an occurrence of, a variable on the RHS
529
530 * A strict pattern binding; that is, one with an outermost bang
531 !Just _ = e
532 This can fail, so unlike the lazy variant, it is not a no-op.
533 Moreover, Trac #13646 argues that even for single constructor
534 types, you might want to write the constructor. See also #9127.
535
536 * A splice pattern
537 $(th-lhs) = rhs
538 It is impossible to determine whether or not th-lhs really
539 binds any variable. We should disable the warning for any pattern
540 which contain splices, but that is a more expensive check.
541
542 Note [Free-variable space leak]
543 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
544 We have
545 fvs' = trim fvs
546 and we seq fvs' before turning it as part of a record.
547
548 The reason is that trim is sometimes something like
549 \xs -> intersectNameSet (mkNameSet bound_names) xs
550 and we don't want to retain the list bound_names. This showed up in
551 trac ticket #1136.
552 -}
553
554 {- *********************************************************************
555 * *
556 Dependency analysis and other support functions
557 * *
558 ********************************************************************* -}
559
560 depAnalBinds :: Bag (LHsBind GhcRn, [Name], Uses)
561 -> ([(RecFlag, LHsBinds GhcRn)], DefUses)
562 -- Dependency analysis; this is important so that
563 -- unused-binding reporting is accurate
564 depAnalBinds binds_w_dus
565 = (map get_binds sccs, map get_du sccs)
566 where
567 sccs = depAnal (\(_, defs, _) -> defs)
568 (\(_, _, uses) -> nonDetEltsUniqSet uses)
569 -- It's OK to use nonDetEltsUniqSet here as explained in
570 -- Note [depAnal determinism] in NameEnv.
571 (bagToList binds_w_dus)
572
573 get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind)
574 get_binds (CyclicSCC binds_w_dus) = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus])
575
576 get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses)
577 get_du (CyclicSCC binds_w_dus) = (Just defs, uses)
578 where
579 defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs]
580 uses = unionNameSets [u | (_,_,u) <- binds_w_dus]
581
582 ---------------------
583 -- Bind the top-level forall'd type variables in the sigs.
584 -- E.g f :: forall a. a -> a
585 -- f = rhs
586 -- The 'a' scopes over the rhs
587 --
588 -- NB: there'll usually be just one (for a function binding)
589 -- but if there are many, one may shadow the rest; too bad!
590 -- e.g x :: forall a. [a] -> [a]
591 -- y :: forall a. [(a,a)] -> a
592 -- (x,y) = e
593 -- In e, 'a' will be in scope, and it'll be the one from 'y'!
594
595 mkScopedTvFn :: [LSig GhcRn] -> (Name -> [Name])
596 -- Return a lookup function that maps an Id Name to the names
597 -- of the type variables that should scope over its body.
598 mkScopedTvFn sigs = \n -> lookupNameEnv env n `orElse` []
599 where
600 env = mkHsSigEnv get_scoped_tvs sigs
601
602 get_scoped_tvs :: LSig GhcRn -> Maybe ([Located Name], [Name])
603 -- Returns (binders, scoped tvs for those binders)
604 get_scoped_tvs (L _ (ClassOpSig _ _ names sig_ty))
605 = Just (names, hsScopedTvs sig_ty)
606 get_scoped_tvs (L _ (TypeSig _ names sig_ty))
607 = Just (names, hsWcScopedTvs sig_ty)
608 get_scoped_tvs (L _ (PatSynSig _ names sig_ty))
609 = Just (names, hsScopedTvs sig_ty)
610 get_scoped_tvs _ = Nothing
611
612 -- Process the fixity declarations, making a FastString -> (Located Fixity) map
613 -- (We keep the location around for reporting duplicate fixity declarations.)
614 --
615 -- Checks for duplicates, but not that only locally defined things are fixed.
616 -- Note: for local fixity declarations, duplicates would also be checked in
617 -- check_sigs below. But we also use this function at the top level.
618
619 makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv
620
621 makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls
622 where
623 add_one_sig env (L loc (FixitySig _ names fixity)) =
624 foldlM add_one env [ (loc,name_loc,name,fixity)
625 | L name_loc name <- names ]
626 add_one_sig _ (L _ (XFixitySig _)) = panic "makeMiniFixityEnv"
627
628 add_one env (loc, name_loc, name,fixity) = do
629 { -- this fixity decl is a duplicate iff
630 -- the ReaderName's OccName's FastString is already in the env
631 -- (we only need to check the local fix_env because
632 -- definitions of non-local will be caught elsewhere)
633 let { fs = occNameFS (rdrNameOcc name)
634 ; fix_item = L loc fixity };
635
636 case lookupFsEnv env fs of
637 Nothing -> return $ extendFsEnv env fs fix_item
638 Just (L loc' _) -> do
639 { setSrcSpan loc $
640 addErrAt name_loc (dupFixityDecl loc' name)
641 ; return env}
642 }
643
644 dupFixityDecl :: SrcSpan -> RdrName -> SDoc
645 dupFixityDecl loc rdr_name
646 = vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name),
647 text "also at " <+> ppr loc]
648
649
650 {- *********************************************************************
651 * *
652 Pattern synonym bindings
653 * *
654 ********************************************************************* -}
655
656 rnPatSynBind :: (Name -> [Name]) -- Signature tyvar function
657 -> PatSynBind GhcRn GhcPs
658 -> RnM (PatSynBind GhcRn GhcRn, [Name], Uses)
659 rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
660 , psb_args = details
661 , psb_def = pat
662 , psb_dir = dir })
663 -- invariant: no free vars here when it's a FunBind
664 = do { pattern_synonym_ok <- xoptM LangExt.PatternSynonyms
665 ; unless pattern_synonym_ok (addErr patternSynonymErr)
666 ; let scoped_tvs = sig_fn name
667
668 ; ((pat', details'), fvs1) <- bindSigTyVarsFV scoped_tvs $
669 rnPat PatSyn pat $ \pat' ->
670 -- We check the 'RdrName's instead of the 'Name's
671 -- so that the binding locations are reported
672 -- from the left-hand side
673 case details of
674 PrefixCon vars ->
675 do { checkDupRdrNames vars
676 ; names <- mapM lookupPatSynBndr vars
677 ; return ( (pat', PrefixCon names)
678 , mkFVs (map unLoc names)) }
679 InfixCon var1 var2 ->
680 do { checkDupRdrNames [var1, var2]
681 ; name1 <- lookupPatSynBndr var1
682 ; name2 <- lookupPatSynBndr var2
683 -- ; checkPrecMatch -- TODO
684 ; return ( (pat', InfixCon name1 name2)
685 , mkFVs (map unLoc [name1, name2])) }
686 RecCon vars ->
687 do { checkDupRdrNames (map recordPatSynSelectorId vars)
688 ; let rnRecordPatSynField
689 (RecordPatSynField { recordPatSynSelectorId = visible
690 , recordPatSynPatVar = hidden })
691 = do { visible' <- lookupLocatedTopBndrRn visible
692 ; hidden' <- lookupPatSynBndr hidden
693 ; return $ RecordPatSynField { recordPatSynSelectorId = visible'
694 , recordPatSynPatVar = hidden' } }
695 ; names <- mapM rnRecordPatSynField vars
696 ; return ( (pat', RecCon names)
697 , mkFVs (map (unLoc . recordPatSynPatVar) names)) }
698
699 ; (dir', fvs2) <- case dir of
700 Unidirectional -> return (Unidirectional, emptyFVs)
701 ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs)
702 ExplicitBidirectional mg ->
703 do { (mg', fvs) <- bindSigTyVarsFV scoped_tvs $
704 rnMatchGroup (mkPrefixFunRhs (L l name))
705 rnLExpr mg
706 ; return (ExplicitBidirectional mg', fvs) }
707
708 ; mod <- getModule
709 ; let fvs = fvs1 `plusFV` fvs2
710 fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs
711 -- Keep locally-defined Names
712 -- As well as dependency analysis, we need these for the
713 -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
714
715 bind' = bind{ psb_args = details'
716 , psb_def = pat'
717 , psb_dir = dir'
718 , psb_ext = fvs' }
719 selector_names = case details' of
720 RecCon names ->
721 map (unLoc . recordPatSynSelectorId) names
722 _ -> []
723
724 ; fvs' `seq` -- See Note [Free-variable space leak]
725 return (bind', name : selector_names , fvs1)
726 -- Why fvs1? See Note [Pattern synonym builders don't yield dependencies]
727 }
728 where
729 -- See Note [Renaming pattern synonym variables]
730 lookupPatSynBndr = wrapLocM lookupLocalOccRn
731
732 patternSynonymErr :: SDoc
733 patternSynonymErr
734 = hang (text "Illegal pattern synonym declaration")
735 2 (text "Use -XPatternSynonyms to enable this extension")
736
737 rnPatSynBind _ (XPatSynBind _) = panic "rnPatSynBind"
738
739 {-
740 Note [Renaming pattern synonym variables]
741 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
742
743 We rename pattern synonym declaractions backwards to normal to reuse
744 the logic already implemented for renaming patterns.
745
746 We first rename the RHS of a declaration which brings into
747 scope the variables bound by the pattern (as they would be
748 in normal function definitions). We then lookup the variables
749 which we want to bind in this local environment.
750
751 It is crucial that we then only lookup in the *local* environment which
752 only contains the variables brought into scope by the pattern and nothing
753 else. Amazingly no-one encountered this bug for 3 GHC versions but
754 it was possible to define a pattern synonym which referenced global
755 identifiers and worked correctly.
756
757 ```
758 x = 5
759
760 pattern P :: Int -> ()
761 pattern P x <- _
762
763 f (P x) = x
764
765 > f () = 5
766 ```
767
768 See #13470 for the original report.
769
770 Note [Pattern synonym builders don't yield dependencies]
771 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
772 When renaming a pattern synonym that has an explicit builder,
773 references in the builder definition should not be used when
774 calculating dependencies. For example, consider the following pattern
775 synonym definition:
776
777 pattern P x <- C1 x where
778 P x = f (C1 x)
779
780 f (P x) = C2 x
781
782 In this case, 'P' needs to be typechecked in two passes:
783
784 1. Typecheck the pattern definition of 'P', which fully determines the
785 type of 'P'. This step doesn't require knowing anything about 'f',
786 since the builder definition is not looked at.
787
788 2. Typecheck the builder definition, which needs the typechecked
789 definition of 'f' to be in scope; done by calls oo tcPatSynBuilderBind
790 in TcBinds.tcValBinds.
791
792 This behaviour is implemented in 'tcValBinds', but it crucially
793 depends on 'P' not being put in a recursive group with 'f' (which
794 would make it look like a recursive pattern synonym a la 'pattern P =
795 P' which is unsound and rejected).
796
797 So:
798 * We do not include builder fvs in the Uses returned by rnPatSynBind
799 (which is then used for dependency analysis)
800 * But we /do/ include them in the psb_fvs for the PatSynBind
801 * In rnValBinds we record these builder uses, to avoid bogus
802 unused-variable warnings (Trac #12548)
803 -}
804
805 {- *********************************************************************
806 * *
807 Class/instance method bindings
808 * *
809 ********************************************************************* -}
810
811 {- @rnMethodBinds@ is used for the method bindings of a class and an instance
812 declaration. Like @rnBinds@ but without dependency analysis.
813
814 NOTA BENE: we record each {\em binder} of a method-bind group as a free variable.
815 That's crucial when dealing with an instance decl:
816 \begin{verbatim}
817 instance Foo (T a) where
818 op x = ...
819 \end{verbatim}
820 This might be the {\em sole} occurrence of @op@ for an imported class @Foo@,
821 and unless @op@ occurs we won't treat the type signature of @op@ in the class
822 decl for @Foo@ as a source of instance-decl gates. But we should! Indeed,
823 in many ways the @op@ in an instance decl is just like an occurrence, not
824 a binder.
825 -}
826
827 rnMethodBinds :: Bool -- True <=> is a class declaration
828 -> Name -- Class name
829 -> [Name] -- Type variables from the class/instance header
830 -> LHsBinds GhcPs -- Binds
831 -> [LSig GhcPs] -- and signatures/pragmas
832 -> RnM (LHsBinds GhcRn, [LSig GhcRn], FreeVars)
833 -- Used for
834 -- * the default method bindings in a class decl
835 -- * the method bindings in an instance decl
836 rnMethodBinds is_cls_decl cls ktv_names binds sigs
837 = do { checkDupRdrNames (collectMethodBinders binds)
838 -- Check that the same method is not given twice in the
839 -- same instance decl instance C T where
840 -- f x = ...
841 -- g y = ...
842 -- f x = ...
843 -- We must use checkDupRdrNames because the Name of the
844 -- method is the Name of the class selector, whose SrcSpan
845 -- points to the class declaration; and we use rnMethodBinds
846 -- for instance decls too
847
848 -- Rename the bindings LHSs
849 ; binds' <- foldrBagM (rnMethodBindLHS is_cls_decl cls) emptyBag binds
850
851 -- Rename the pragmas and signatures
852 -- Annoyingly the type variables /are/ in scope for signatures, but
853 -- /are not/ in scope in the SPECIALISE instance pramas; e.g.
854 -- instance Eq a => Eq (T a) where
855 -- (==) :: a -> a -> a
856 -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
857 ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs
858 bound_nms = mkNameSet (collectHsBindsBinders binds')
859 sig_ctxt | is_cls_decl = ClsDeclCtxt cls
860 | otherwise = InstDeclCtxt bound_nms
861 ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags
862 ; (other_sigs', sig_fvs) <- extendTyVarEnvFVRn ktv_names $
863 renameSigs sig_ctxt other_sigs
864
865 -- Rename the bindings RHSs. Again there's an issue about whether the
866 -- type variables from the class/instance head are in scope.
867 -- Answer no in Haskell 2010, but yes if you have -XScopedTypeVariables
868 ; scoped_tvs <- xoptM LangExt.ScopedTypeVariables
869 ; (binds'', bind_fvs) <- maybe_extend_tyvar_env scoped_tvs $
870 do { binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn other_sigs')) binds'
871 ; let bind_fvs = foldrBag (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2)
872 emptyFVs binds_w_dus
873 ; return (mapBag fstOf3 binds_w_dus, bind_fvs) }
874
875 ; return ( binds'', spec_inst_prags' ++ other_sigs'
876 , sig_fvs `plusFV` sip_fvs `plusFV` bind_fvs) }
877 where
878 -- For the method bindings in class and instance decls, we extend
879 -- the type variable environment iff -XScopedTypeVariables
880 maybe_extend_tyvar_env scoped_tvs thing_inside
881 | scoped_tvs = extendTyVarEnvFVRn ktv_names thing_inside
882 | otherwise = thing_inside
883
884 rnMethodBindLHS :: Bool -> Name
885 -> LHsBindLR GhcPs GhcPs
886 -> LHsBindsLR GhcRn GhcPs
887 -> RnM (LHsBindsLR GhcRn GhcPs)
888 rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest
889 = setSrcSpan loc $ do
890 do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name
891 -- We use the selector name as the binder
892 ; let bind' = bind { fun_id = sel_name, fun_ext = noExt }
893 ; return (L loc bind' `consBag` rest ) }
894
895 -- Report error for all other forms of bindings
896 -- This is why we use a fold rather than map
897 rnMethodBindLHS is_cls_decl _ (L loc bind) rest
898 = do { addErrAt loc $
899 vcat [ what <+> text "not allowed in" <+> decl_sort
900 , nest 2 (ppr bind) ]
901 ; return rest }
902 where
903 decl_sort | is_cls_decl = text "class declaration:"
904 | otherwise = text "instance declaration:"
905 what = case bind of
906 PatBind {} -> text "Pattern bindings (except simple variables)"
907 PatSynBind {} -> text "Pattern synonyms"
908 -- Associated pattern synonyms are not implemented yet
909 _ -> pprPanic "rnMethodBind" (ppr bind)
910
911 {-
912 ************************************************************************
913 * *
914 \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
915 * *
916 ************************************************************************
917
918 @renameSigs@ checks for:
919 \begin{enumerate}
920 \item more than one sig for one thing;
921 \item signatures given for things not bound here;
922 \end{enumerate}
923
924 At the moment we don't gather free-var info from the types in
925 signatures. We'd only need this if we wanted to report unused tyvars.
926 -}
927
928 renameSigs :: HsSigCtxt
929 -> [LSig GhcPs]
930 -> RnM ([LSig GhcRn], FreeVars)
931 -- Renames the signatures and performs error checks
932 renameSigs ctxt sigs
933 = do { mapM_ dupSigDeclErr (findDupSigs sigs)
934
935 ; checkDupMinimalSigs sigs
936
937 ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs
938
939 ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs'
940 ; mapM_ misplacedSigErr bad_sigs -- Misplaced
941
942 ; return (good_sigs, sig_fvs) }
943
944 ----------------------
945 -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
946 -- because this won't work for:
947 -- instance Foo T where
948 -- {-# INLINE op #-}
949 -- Baz.op = ...
950 -- We'll just rename the INLINE prag to refer to whatever other 'op'
951 -- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.)
952 -- Doesn't seem worth much trouble to sort this.
953
954 renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars)
955 renameSig _ (IdSig _ x)
956 = return (IdSig noExt x, emptyFVs) -- Actually this never occurs
957
958 renameSig ctxt sig@(TypeSig _ vs ty)
959 = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
960 ; let doc = TypeSigCtx (ppr_sig_bndrs vs)
961 ; (new_ty, fvs) <- rnHsSigWcType doc ty
962 ; return (TypeSig noExt new_vs new_ty, fvs) }
963
964 renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)
965 = do { defaultSigs_on <- xoptM LangExt.DefaultSignatures
966 ; when (is_deflt && not defaultSigs_on) $
967 addErr (defaultSigErr sig)
968 ; new_v <- mapM (lookupSigOccRn ctxt sig) vs
969 ; (new_ty, fvs) <- rnHsSigType ty_ctxt ty
970 ; return (ClassOpSig noExt is_deflt new_v new_ty, fvs) }
971 where
972 (v1:_) = vs
973 ty_ctxt = GenericCtx (text "a class method signature for"
974 <+> quotes (ppr v1))
975
976 renameSig _ (SpecInstSig _ src ty)
977 = do { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx ty
978 ; return (SpecInstSig noExt src new_ty,fvs) }
979
980 -- {-# SPECIALISE #-} pragmas can refer to imported Ids
981 -- so, in the top-level case (when mb_names is Nothing)
982 -- we use lookupOccRn. If there's both an imported and a local 'f'
983 -- then the SPECIALISE pragma is ambiguous, unlike all other signatures
984 renameSig ctxt sig@(SpecSig _ v tys inl)
985 = do { new_v <- case ctxt of
986 TopSigCtxt {} -> lookupLocatedOccRn v
987 _ -> lookupSigOccRn ctxt sig v
988 ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys
989 ; return (SpecSig noExt new_v new_ty inl, fvs) }
990 where
991 ty_ctxt = GenericCtx (text "a SPECIALISE signature for"
992 <+> quotes (ppr v))
993 do_one (tys,fvs) ty
994 = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt ty
995 ; return ( new_ty:tys, fvs_ty `plusFV` fvs) }
996
997 renameSig ctxt sig@(InlineSig _ v s)
998 = do { new_v <- lookupSigOccRn ctxt sig v
999 ; return (InlineSig noExt new_v s, emptyFVs) }
1000
1001 renameSig ctxt (FixSig _ fsig)
1002 = do { new_fsig <- rnSrcFixityDecl ctxt fsig
1003 ; return (FixSig noExt new_fsig, emptyFVs) }
1004
1005 renameSig ctxt sig@(MinimalSig _ s (L l bf))
1006 = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf
1007 return (MinimalSig noExt s (L l new_bf), emptyFVs)
1008
1009 renameSig ctxt sig@(PatSynSig _ vs ty)
1010 = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
1011 ; (ty', fvs) <- rnHsSigType ty_ctxt ty
1012 ; return (PatSynSig noExt new_vs ty', fvs) }
1013 where
1014 ty_ctxt = GenericCtx (text "a pattern synonym signature for"
1015 <+> ppr_sig_bndrs vs)
1016
1017 renameSig ctxt sig@(SCCFunSig _ st v s)
1018 = do { new_v <- lookupSigOccRn ctxt sig v
1019 ; return (SCCFunSig noExt st new_v s, emptyFVs) }
1020
1021 -- COMPLETE Sigs can refer to imported IDs which is why we use
1022 -- lookupLocatedOccRn rather than lookupSigOccRn
1023 renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty)
1024 = do new_bf <- traverse lookupLocatedOccRn bf
1025 new_mty <- traverse lookupLocatedOccRn mty
1026
1027 this_mod <- fmap tcg_mod getGblEnv
1028 unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $ do
1029 -- Why 'any'? See Note [Orphan COMPLETE pragmas]
1030 addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError
1031
1032 return (CompleteMatchSig noExt s (L l new_bf) new_mty, emptyFVs)
1033 where
1034 orphanError :: SDoc
1035 orphanError =
1036 text "Orphan COMPLETE pragmas not supported" $$
1037 text "A COMPLETE pragma must mention at least one data constructor" $$
1038 text "or pattern synonym defined in the same module."
1039
1040 renameSig _ (XSig _) = panic "renameSig"
1041
1042 {-
1043 Note [Orphan COMPLETE pragmas]
1044 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1045 We define a COMPLETE pragma to be a non-orphan if it includes at least
1046 one conlike defined in the current module. Why is this sufficient?
1047 Well if you have a pattern match
1048
1049 case expr of
1050 P1 -> ...
1051 P2 -> ...
1052 P3 -> ...
1053
1054 any COMPLETE pragma which mentions a conlike other than P1, P2 or P3
1055 will not be of any use in verifying that the pattern match is
1056 exhaustive. So as we have certainly read the interface files that
1057 define P1, P2 and P3, we will have loaded all non-orphan COMPLETE
1058 pragmas that could be relevant to this pattern match.
1059
1060 For now we simply disallow orphan COMPLETE pragmas, as the added
1061 complexity of supporting them properly doesn't seem worthwhile.
1062 -}
1063
1064 ppr_sig_bndrs :: [Located RdrName] -> SDoc
1065 ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
1066
1067 okHsSig :: HsSigCtxt -> LSig a -> Bool
1068 okHsSig ctxt (L _ sig)
1069 = case (sig, ctxt) of
1070 (ClassOpSig {}, ClsDeclCtxt {}) -> True
1071 (ClassOpSig {}, InstDeclCtxt {}) -> True
1072 (ClassOpSig {}, _) -> False
1073
1074 (TypeSig {}, ClsDeclCtxt {}) -> False
1075 (TypeSig {}, InstDeclCtxt {}) -> False
1076 (TypeSig {}, _) -> True
1077
1078 (PatSynSig {}, TopSigCtxt{}) -> True
1079 (PatSynSig {}, _) -> False
1080
1081 (FixSig {}, InstDeclCtxt {}) -> False
1082 (FixSig {}, _) -> True
1083
1084 (IdSig {}, TopSigCtxt {}) -> True
1085 (IdSig {}, InstDeclCtxt {}) -> True
1086 (IdSig {}, _) -> False
1087
1088 (InlineSig {}, HsBootCtxt {}) -> False
1089 (InlineSig {}, _) -> True
1090
1091 (SpecSig {}, TopSigCtxt {}) -> True
1092 (SpecSig {}, LocalBindCtxt {}) -> True
1093 (SpecSig {}, InstDeclCtxt {}) -> True
1094 (SpecSig {}, _) -> False
1095
1096 (SpecInstSig {}, InstDeclCtxt {}) -> True
1097 (SpecInstSig {}, _) -> False
1098
1099 (MinimalSig {}, ClsDeclCtxt {}) -> True
1100 (MinimalSig {}, _) -> False
1101
1102 (SCCFunSig {}, HsBootCtxt {}) -> False
1103 (SCCFunSig {}, _) -> True
1104
1105 (CompleteMatchSig {}, TopSigCtxt {} ) -> True
1106 (CompleteMatchSig {}, _) -> False
1107
1108 (XSig _, _) -> panic "okHsSig"
1109
1110 -------------------
1111 findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)]
1112 -- Check for duplicates on RdrName version,
1113 -- because renamed version has unboundName for
1114 -- not-in-scope binders, which gives bogus dup-sig errors
1115 -- NB: in a class decl, a 'generic' sig is not considered
1116 -- equal to an ordinary sig, so we allow, say
1117 -- class C a where
1118 -- op :: a -> a
1119 -- default op :: Eq a => a -> a
1120 findDupSigs sigs
1121 = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs)
1122 where
1123 expand_sig sig@(FixSig _ (FixitySig _ ns _)) = zip ns (repeat sig)
1124 expand_sig sig@(InlineSig _ n _) = [(n,sig)]
1125 expand_sig sig@(TypeSig _ ns _) = [(n,sig) | n <- ns]
1126 expand_sig sig@(ClassOpSig _ _ ns _) = [(n,sig) | n <- ns]
1127 expand_sig sig@(PatSynSig _ ns _ ) = [(n,sig) | n <- ns]
1128 expand_sig sig@(SCCFunSig _ _ n _) = [(n,sig)]
1129 expand_sig _ = []
1130
1131 matching_sig (L _ n1,sig1) (L _ n2,sig2) = n1 == n2 && mtch sig1 sig2
1132 mtch (FixSig {}) (FixSig {}) = True
1133 mtch (InlineSig {}) (InlineSig {}) = True
1134 mtch (TypeSig {}) (TypeSig {}) = True
1135 mtch (ClassOpSig _ d1 _ _) (ClassOpSig _ d2 _ _) = d1 == d2
1136 mtch (PatSynSig _ _ _) (PatSynSig _ _ _) = True
1137 mtch (SCCFunSig{}) (SCCFunSig{}) = True
1138 mtch _ _ = False
1139
1140 -- Warn about multiple MINIMAL signatures
1141 checkDupMinimalSigs :: [LSig GhcPs] -> RnM ()
1142 checkDupMinimalSigs sigs
1143 = case filter isMinimalLSig sigs of
1144 minSigs@(_:_:_) -> dupMinimalSigErr minSigs
1145 _ -> return ()
1146
1147 {-
1148 ************************************************************************
1149 * *
1150 \subsection{Match}
1151 * *
1152 ************************************************************************
1153 -}
1154
1155 rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext Name
1156 -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
1157 -> MatchGroup GhcPs (Located (body GhcPs))
1158 -> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars)
1159 rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin })
1160 = do { empty_case_ok <- xoptM LangExt.EmptyCase
1161 ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))
1162 ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms
1163 ; return (mkMatchGroup origin new_ms, ms_fvs) }
1164 rnMatchGroup _ _ (XMatchGroup {}) = panic "rnMatchGroup"
1165
1166 rnMatch :: Outputable (body GhcPs) => HsMatchContext Name
1167 -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
1168 -> LMatch GhcPs (Located (body GhcPs))
1169 -> RnM (LMatch GhcRn (Located (body GhcRn)), FreeVars)
1170 rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody)
1171
1172 rnMatch' :: Outputable (body GhcPs) => HsMatchContext Name
1173 -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
1174 -> Match GhcPs (Located (body GhcPs))
1175 -> RnM (Match GhcRn (Located (body GhcRn)), FreeVars)
1176 rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })
1177 = do { -- Note that there are no local fixity decls for matches
1178 ; rnPats ctxt pats $ \ pats' -> do
1179 { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss
1180 ; let mf' = case (ctxt, mf) of
1181 (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ })
1182 -> mf { mc_fun = L lf funid }
1183 _ -> ctxt
1184 ; return (Match { m_ext = noExt, m_ctxt = mf', m_pats = pats'
1185 , m_grhss = grhss'}, grhss_fvs ) }}
1186 rnMatch' _ _ (XMatch _) = panic "rnMatch'"
1187
1188 emptyCaseErr :: HsMatchContext Name -> SDoc
1189 emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)
1190 2 (text "Use EmptyCase to allow this")
1191 where
1192 pp_ctxt = case ctxt of
1193 CaseAlt -> text "case expression"
1194 LambdaExpr -> text "\\case expression"
1195 _ -> text "(unexpected)" <+> pprMatchContextNoun ctxt
1196
1197 {-
1198 ************************************************************************
1199 * *
1200 \subsubsection{Guarded right-hand sides (GRHSs)}
1201 * *
1202 ************************************************************************
1203 -}
1204
1205 rnGRHSs :: HsMatchContext Name
1206 -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
1207 -> GRHSs GhcPs (Located (body GhcPs))
1208 -> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars)
1209 rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds))
1210 = rnLocalBindsAndThen binds $ \ binds' _ -> do
1211 (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss
1212 return (GRHSs noExt grhss' (L l binds'), fvGRHSs)
1213 rnGRHSs _ _ (XGRHSs _) = panic "rnGRHSs"
1214
1215 rnGRHS :: HsMatchContext Name
1216 -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
1217 -> LGRHS GhcPs (Located (body GhcPs))
1218 -> RnM (LGRHS GhcRn (Located (body GhcRn)), FreeVars)
1219 rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody)
1220
1221 rnGRHS' :: HsMatchContext Name
1222 -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
1223 -> GRHS GhcPs (Located (body GhcPs))
1224 -> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars)
1225 rnGRHS' ctxt rnBody (GRHS _ guards rhs)
1226 = do { pattern_guards_allowed <- xoptM LangExt.PatternGuards
1227 ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ ->
1228 rnBody rhs
1229
1230 ; unless (pattern_guards_allowed || is_standard_guard guards')
1231 (addWarn NoReason (nonStdGuardErr guards'))
1232
1233 ; return (GRHS noExt guards' rhs', fvs) }
1234 where
1235 -- Standard Haskell 1.4 guards are just a single boolean
1236 -- expression, rather than a list of qualifiers as in the
1237 -- Glasgow extension
1238 is_standard_guard [] = True
1239 is_standard_guard [L _ (BodyStmt {})] = True
1240 is_standard_guard _ = False
1241 rnGRHS' _ _ (XGRHS _) = panic "rnGRHS'"
1242
1243 {-
1244 *********************************************************
1245 * *
1246 Source-code fixity declarations
1247 * *
1248 *********************************************************
1249 -}
1250
1251 rnSrcFixityDecl :: HsSigCtxt -> FixitySig GhcPs -> RnM (FixitySig GhcRn)
1252 -- Rename a fixity decl, so we can put
1253 -- the renamed decl in the renamed syntax tree
1254 -- Errors if the thing being fixed is not defined locally.
1255 rnSrcFixityDecl sig_ctxt = rn_decl
1256 where
1257 rn_decl :: FixitySig GhcPs -> RnM (FixitySig GhcRn)
1258 -- GHC extension: look up both the tycon and data con
1259 -- for con-like things; hence returning a list
1260 -- If neither are in scope, report an error; otherwise
1261 -- return a fixity sig for each (slightly odd)
1262 rn_decl (FixitySig _ fnames fixity)
1263 = do names <- concatMapM lookup_one fnames
1264 return (FixitySig noExt names fixity)
1265 rn_decl (XFixitySig _) = panic "rnSrcFixityDecl"
1266
1267 lookup_one :: Located RdrName -> RnM [Located Name]
1268 lookup_one (L name_loc rdr_name)
1269 = setSrcSpan name_loc $
1270 -- This lookup will fail if the name is not defined in the
1271 -- same binding group as this fixity declaration.
1272 do names <- lookupLocalTcNames sig_ctxt what rdr_name
1273 return [ L name_loc name | (_, name) <- names ]
1274 what = text "fixity signature"
1275
1276 {-
1277 ************************************************************************
1278 * *
1279 \subsection{Error messages}
1280 * *
1281 ************************************************************************
1282 -}
1283
1284 dupSigDeclErr :: NonEmpty (Located RdrName, Sig GhcPs) -> RnM ()
1285 dupSigDeclErr pairs@((L loc name, sig) :| _)
1286 = addErrAt loc $
1287 vcat [ text "Duplicate" <+> what_it_is
1288 <> text "s for" <+> quotes (ppr name)
1289 , text "at" <+> vcat (map ppr $ sort
1290 $ map (getLoc . fst)
1291 $ toList pairs)
1292 ]
1293 where
1294 what_it_is = hsSigDoc sig
1295
1296 misplacedSigErr :: LSig GhcRn -> RnM ()
1297 misplacedSigErr (L loc sig)
1298 = addErrAt loc $
1299 sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig]
1300
1301 defaultSigErr :: Sig GhcPs -> SDoc
1302 defaultSigErr sig = vcat [ hang (text "Unexpected default signature:")
1303 2 (ppr sig)
1304 , text "Use DefaultSignatures to enable default signatures" ]
1305
1306 bindsInHsBootFile :: LHsBindsLR GhcRn GhcPs -> SDoc
1307 bindsInHsBootFile mbinds
1308 = hang (text "Bindings in hs-boot files are not allowed")
1309 2 (ppr mbinds)
1310
1311 nonStdGuardErr :: Outputable body => [LStmtLR GhcRn GhcRn body] -> SDoc
1312 nonStdGuardErr guards
1313 = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)")
1314 4 (interpp'SP guards)
1315
1316 unusedPatBindWarn :: HsBind GhcRn -> SDoc
1317 unusedPatBindWarn bind
1318 = hang (text "This pattern-binding binds no variables:")
1319 2 (ppr bind)
1320
1321 dupMinimalSigErr :: [LSig GhcPs] -> RnM ()
1322 dupMinimalSigErr sigs@(L loc _ : _)
1323 = addErrAt loc $
1324 vcat [ text "Multiple minimal complete definitions"
1325 , text "at" <+> vcat (map ppr $ sort $ map getLoc sigs)
1326 , text "Combine alternative minimal complete definitions with `|'" ]
1327 dupMinimalSigErr [] = panic "dupMinimalSigErr"