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