bf3ee26ae70d7153282f2f98e5c68da15acbf357
[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,
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 -- FixitySig is renamed elsewhere.
945 renameSig _ (IdSig x)
946 = return (IdSig x, emptyFVs) -- Actually this never occurs
947
948 renameSig ctxt sig@(TypeSig vs ty)
949 = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
950 ; let doc = TypeSigCtx (ppr_sig_bndrs vs)
951 ; (new_ty, fvs) <- rnHsSigWcType doc ty
952 ; return (TypeSig new_vs new_ty, fvs) }
953
954 renameSig ctxt sig@(ClassOpSig is_deflt vs ty)
955 = do { defaultSigs_on <- xoptM LangExt.DefaultSignatures
956 ; when (is_deflt && not defaultSigs_on) $
957 addErr (defaultSigErr sig)
958 ; new_v <- mapM (lookupSigOccRn ctxt sig) vs
959 ; (new_ty, fvs) <- rnHsSigType ty_ctxt ty
960 ; return (ClassOpSig is_deflt new_v new_ty, fvs) }
961 where
962 (v1:_) = vs
963 ty_ctxt = GenericCtx (text "a class method signature for"
964 <+> quotes (ppr v1))
965
966 renameSig _ (SpecInstSig src ty)
967 = do { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx ty
968 ; return (SpecInstSig src new_ty,fvs) }
969
970 -- {-# SPECIALISE #-} pragmas can refer to imported Ids
971 -- so, in the top-level case (when mb_names is Nothing)
972 -- we use lookupOccRn. If there's both an imported and a local 'f'
973 -- then the SPECIALISE pragma is ambiguous, unlike all other signatures
974 renameSig ctxt sig@(SpecSig v tys inl)
975 = do { new_v <- case ctxt of
976 TopSigCtxt {} -> lookupLocatedOccRn v
977 _ -> lookupSigOccRn ctxt sig v
978 ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys
979 ; return (SpecSig new_v new_ty inl, fvs) }
980 where
981 ty_ctxt = GenericCtx (text "a SPECIALISE signature for"
982 <+> quotes (ppr v))
983 do_one (tys,fvs) ty
984 = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt ty
985 ; return ( new_ty:tys, fvs_ty `plusFV` fvs) }
986
987 renameSig ctxt sig@(InlineSig v s)
988 = do { new_v <- lookupSigOccRn ctxt sig v
989 ; return (InlineSig new_v s, emptyFVs) }
990
991 renameSig ctxt sig@(FixSig (FixitySig vs f))
992 = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
993 ; return (FixSig (FixitySig new_vs f), emptyFVs) }
994
995 renameSig ctxt sig@(MinimalSig s (L l bf))
996 = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf
997 return (MinimalSig s (L l new_bf), emptyFVs)
998
999 renameSig ctxt sig@(PatSynSig vs ty)
1000 = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
1001 ; (ty', fvs) <- rnHsSigType ty_ctxt ty
1002 ; return (PatSynSig new_vs ty', fvs) }
1003 where
1004 ty_ctxt = GenericCtx (text "a pattern synonym signature for"
1005 <+> ppr_sig_bndrs vs)
1006
1007 renameSig ctxt sig@(SCCFunSig st v s)
1008 = do { new_v <- lookupSigOccRn ctxt sig v
1009 ; return (SCCFunSig st new_v s, emptyFVs) }
1010
1011 -- COMPLETE Sigs can refer to imported IDs which is why we use
1012 -- lookupLocatedOccRn rather than lookupSigOccRn
1013 renameSig _ctxt sig@(CompleteMatchSig s (L l bf) mty)
1014 = do new_bf <- traverse lookupLocatedOccRn bf
1015 new_mty <- traverse lookupLocatedOccRn mty
1016
1017 this_mod <- fmap tcg_mod getGblEnv
1018 unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $ do
1019 -- Why 'any'? See Note [Orphan COMPLETE pragmas]
1020 addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError
1021
1022 return (CompleteMatchSig s (L l new_bf) new_mty, emptyFVs)
1023 where
1024 orphanError :: SDoc
1025 orphanError =
1026 text "Orphan COMPLETE pragmas not supported" $$
1027 text "A COMPLETE pragma must mention at least one data constructor" $$
1028 text "or pattern synonym defined in the same module."
1029
1030 {-
1031 Note [Orphan COMPLETE pragmas]
1032 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1033 We define a COMPLETE pragma to be a non-orphan if it includes at least
1034 one conlike defined in the current module. Why is this sufficient?
1035 Well if you have a pattern match
1036
1037 case expr of
1038 P1 -> ...
1039 P2 -> ...
1040 P3 -> ...
1041
1042 any COMPLETE pragma which mentions a conlike other than P1, P2 or P3
1043 will not be of any use in verifying that the pattern match is
1044 exhaustive. So as we have certainly read the interface files that
1045 define P1, P2 and P3, we will have loaded all non-orphan COMPLETE
1046 pragmas that could be relevant to this pattern match.
1047
1048 For now we simply disallow orphan COMPLETE pragmas, as the added
1049 complexity of supporting them properly doesn't seem worthwhile.
1050 -}
1051
1052 ppr_sig_bndrs :: [Located RdrName] -> SDoc
1053 ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
1054
1055 okHsSig :: HsSigCtxt -> LSig a -> Bool
1056 okHsSig ctxt (L _ sig)
1057 = case (sig, ctxt) of
1058 (ClassOpSig {}, ClsDeclCtxt {}) -> True
1059 (ClassOpSig {}, InstDeclCtxt {}) -> True
1060 (ClassOpSig {}, _) -> False
1061
1062 (TypeSig {}, ClsDeclCtxt {}) -> False
1063 (TypeSig {}, InstDeclCtxt {}) -> False
1064 (TypeSig {}, _) -> True
1065
1066 (PatSynSig {}, TopSigCtxt{}) -> True
1067 (PatSynSig {}, _) -> False
1068
1069 (FixSig {}, InstDeclCtxt {}) -> False
1070 (FixSig {}, _) -> True
1071
1072 (IdSig {}, TopSigCtxt {}) -> True
1073 (IdSig {}, InstDeclCtxt {}) -> True
1074 (IdSig {}, _) -> False
1075
1076 (InlineSig {}, HsBootCtxt {}) -> False
1077 (InlineSig {}, _) -> True
1078
1079 (SpecSig {}, TopSigCtxt {}) -> True
1080 (SpecSig {}, LocalBindCtxt {}) -> True
1081 (SpecSig {}, InstDeclCtxt {}) -> True
1082 (SpecSig {}, _) -> False
1083
1084 (SpecInstSig {}, InstDeclCtxt {}) -> True
1085 (SpecInstSig {}, _) -> False
1086
1087 (MinimalSig {}, ClsDeclCtxt {}) -> True
1088 (MinimalSig {}, _) -> False
1089
1090 (SCCFunSig {}, HsBootCtxt {}) -> False
1091 (SCCFunSig {}, _) -> True
1092
1093 (CompleteMatchSig {}, TopSigCtxt {} ) -> True
1094 (CompleteMatchSig {}, _) -> False
1095
1096 -------------------
1097 findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)]
1098 -- Check for duplicates on RdrName version,
1099 -- because renamed version has unboundName for
1100 -- not-in-scope binders, which gives bogus dup-sig errors
1101 -- NB: in a class decl, a 'generic' sig is not considered
1102 -- equal to an ordinary sig, so we allow, say
1103 -- class C a where
1104 -- op :: a -> a
1105 -- default op :: Eq a => a -> a
1106 findDupSigs sigs
1107 = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs)
1108 where
1109 expand_sig sig@(FixSig (FixitySig ns _)) = zip ns (repeat sig)
1110 expand_sig sig@(InlineSig n _) = [(n,sig)]
1111 expand_sig sig@(TypeSig ns _) = [(n,sig) | n <- ns]
1112 expand_sig sig@(ClassOpSig _ ns _) = [(n,sig) | n <- ns]
1113 expand_sig sig@(PatSynSig ns _ ) = [(n,sig) | n <- ns]
1114 expand_sig sig@(SCCFunSig _ n _) = [(n,sig)]
1115 expand_sig _ = []
1116
1117 matching_sig (L _ n1,sig1) (L _ n2,sig2) = n1 == n2 && mtch sig1 sig2
1118 mtch (FixSig {}) (FixSig {}) = True
1119 mtch (InlineSig {}) (InlineSig {}) = True
1120 mtch (TypeSig {}) (TypeSig {}) = True
1121 mtch (ClassOpSig d1 _ _) (ClassOpSig d2 _ _) = d1 == d2
1122 mtch (PatSynSig _ _) (PatSynSig _ _) = True
1123 mtch (SCCFunSig{}) (SCCFunSig{}) = True
1124 mtch _ _ = False
1125
1126 -- Warn about multiple MINIMAL signatures
1127 checkDupMinimalSigs :: [LSig GhcPs] -> RnM ()
1128 checkDupMinimalSigs sigs
1129 = case filter isMinimalLSig sigs of
1130 minSigs@(_:_:_) -> dupMinimalSigErr minSigs
1131 _ -> return ()
1132
1133 {-
1134 ************************************************************************
1135 * *
1136 \subsection{Match}
1137 * *
1138 ************************************************************************
1139 -}
1140
1141 rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext Name
1142 -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
1143 -> MatchGroup GhcPs (Located (body GhcPs))
1144 -> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars)
1145 rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin })
1146 = do { empty_case_ok <- xoptM LangExt.EmptyCase
1147 ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))
1148 ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms
1149 ; return (mkMatchGroup origin new_ms, ms_fvs) }
1150
1151 rnMatch :: Outputable (body GhcPs) => HsMatchContext Name
1152 -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
1153 -> LMatch GhcPs (Located (body GhcPs))
1154 -> RnM (LMatch GhcRn (Located (body GhcRn)), FreeVars)
1155 rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody)
1156
1157 rnMatch' :: Outputable (body GhcPs) => HsMatchContext Name
1158 -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
1159 -> Match GhcPs (Located (body GhcPs))
1160 -> RnM (Match GhcRn (Located (body GhcRn)), FreeVars)
1161 rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })
1162 = do { -- Note that there are no local fixity decls for matches
1163 ; rnPats ctxt pats $ \ pats' -> do
1164 { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss
1165 ; let mf' = case (ctxt, mf) of
1166 (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ })
1167 -> mf { mc_fun = L lf funid }
1168 _ -> ctxt
1169 ; return (Match { m_ctxt = mf', m_pats = pats'
1170 , m_grhss = grhss'}, grhss_fvs ) }}
1171
1172 emptyCaseErr :: HsMatchContext Name -> SDoc
1173 emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)
1174 2 (text "Use EmptyCase to allow this")
1175 where
1176 pp_ctxt = case ctxt of
1177 CaseAlt -> text "case expression"
1178 LambdaExpr -> text "\\case expression"
1179 _ -> text "(unexpected)" <+> pprMatchContextNoun ctxt
1180
1181 {-
1182 ************************************************************************
1183 * *
1184 \subsubsection{Guarded right-hand sides (GRHSs)}
1185 * *
1186 ************************************************************************
1187 -}
1188
1189 rnGRHSs :: HsMatchContext Name
1190 -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
1191 -> GRHSs GhcPs (Located (body GhcPs))
1192 -> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars)
1193 rnGRHSs ctxt rnBody (GRHSs grhss (L l binds))
1194 = rnLocalBindsAndThen binds $ \ binds' _ -> do
1195 (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss
1196 return (GRHSs grhss' (L l binds'), fvGRHSs)
1197
1198 rnGRHS :: HsMatchContext Name
1199 -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
1200 -> LGRHS GhcPs (Located (body GhcPs))
1201 -> RnM (LGRHS GhcRn (Located (body GhcRn)), FreeVars)
1202 rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody)
1203
1204 rnGRHS' :: HsMatchContext Name
1205 -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
1206 -> GRHS GhcPs (Located (body GhcPs))
1207 -> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars)
1208 rnGRHS' ctxt rnBody (GRHS guards rhs)
1209 = do { pattern_guards_allowed <- xoptM LangExt.PatternGuards
1210 ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ ->
1211 rnBody rhs
1212
1213 ; unless (pattern_guards_allowed || is_standard_guard guards')
1214 (addWarn NoReason (nonStdGuardErr guards'))
1215
1216 ; return (GRHS guards' rhs', fvs) }
1217 where
1218 -- Standard Haskell 1.4 guards are just a single boolean
1219 -- expression, rather than a list of qualifiers as in the
1220 -- Glasgow extension
1221 is_standard_guard [] = True
1222 is_standard_guard [L _ (BodyStmt _ _ _ _)] = True
1223 is_standard_guard _ = False
1224
1225 {-
1226 ************************************************************************
1227 * *
1228 \subsection{Error messages}
1229 * *
1230 ************************************************************************
1231 -}
1232
1233 dupSigDeclErr :: NonEmpty (Located RdrName, Sig GhcPs) -> RnM ()
1234 dupSigDeclErr pairs@((L loc name, sig) :| _)
1235 = addErrAt loc $
1236 vcat [ text "Duplicate" <+> what_it_is
1237 <> text "s for" <+> quotes (ppr name)
1238 , text "at" <+> vcat (map ppr $ sort
1239 $ map (getLoc . fst)
1240 $ toList pairs)
1241 ]
1242 where
1243 what_it_is = hsSigDoc sig
1244
1245 misplacedSigErr :: LSig GhcRn -> RnM ()
1246 misplacedSigErr (L loc sig)
1247 = addErrAt loc $
1248 sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig]
1249
1250 defaultSigErr :: Sig GhcPs -> SDoc
1251 defaultSigErr sig = vcat [ hang (text "Unexpected default signature:")
1252 2 (ppr sig)
1253 , text "Use DefaultSignatures to enable default signatures" ]
1254
1255 bindsInHsBootFile :: LHsBindsLR GhcRn GhcPs -> SDoc
1256 bindsInHsBootFile mbinds
1257 = hang (text "Bindings in hs-boot files are not allowed")
1258 2 (ppr mbinds)
1259
1260 nonStdGuardErr :: Outputable body => [LStmtLR GhcRn GhcRn body] -> SDoc
1261 nonStdGuardErr guards
1262 = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)")
1263 4 (interpp'SP guards)
1264
1265 unusedPatBindWarn :: HsBind GhcRn -> SDoc
1266 unusedPatBindWarn bind
1267 = hang (text "This pattern-binding binds no variables:")
1268 2 (ppr bind)
1269
1270 dupMinimalSigErr :: [LSig GhcPs] -> RnM ()
1271 dupMinimalSigErr sigs@(L loc _ : _)
1272 = addErrAt loc $
1273 vcat [ text "Multiple minimal complete definitions"
1274 , text "at" <+> vcat (map ppr $ sort $ map getLoc sigs)
1275 , text "Combine alternative minimal complete definitions with `|'" ]
1276 dupMinimalSigErr [] = panic "dupMinimalSigErr"