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