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