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