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