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