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