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