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