Hurrah! This major commit adds support for scoped kind variables,
[ghc.git] / compiler / rename / RnBinds.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[RnBinds]{Renaming and dependency analysis of bindings}
5
6 This module does renaming and dependency analysis on value bindings in
7 the abstract syntax.  It does {\em not} do cycle-checks on class or
8 type-synonym declarations; those cannot be done at this stage because
9 they may be affected by renaming (which isn't fully worked out yet).
10
11 \begin{code}
12 {-# OPTIONS -fno-warn-tabs #-}
13 -- The above warning supression flag is a temporary kludge.
14 -- While working on this module you are encouraged to remove it and
15 -- detab the module (please do the detabbing in a separate patch). See
16 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
17 -- for details
18
19 module RnBinds (
20    -- Renaming top-level bindings
21    rnTopBindsLHS, rnTopBindsRHS, rnValBindsRHS,
22
23    -- Renaming local bindings
24    rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
25
26    -- Other bindings
27    rnMethodBinds, renameSigs, mkSigTvFn,
28    rnMatchGroup, rnGRHSs,
29    makeMiniFixityEnv, MiniFixityEnv,
30    HsSigCtxt(..)
31    ) where
32
33 import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
34
35 import HsSyn
36 import TcRnMonad
37 import TcEvidence     ( emptyTcEvBinds )
38 import RnTypes        ( bindSigTyVarsFV, rnIPName, rnHsSigType, rnLHsType, checkPrecMatch )
39 import RnPat
40 import RnEnv
41 import DynFlags
42 import Name
43 import NameEnv
44 import NameSet
45 import RdrName          ( RdrName, rdrNameOcc )
46 import SrcLoc
47 import ListSetOps       ( findDupsEq )
48 import BasicTypes       ( RecFlag(..) )
49 import Digraph          ( SCC(..), stronglyConnCompFromEdgedVertices )
50 import Bag
51 import Outputable
52 import FastString
53 import Data.List        ( partition )
54 import Maybes           ( orElse )
55 import Control.Monad
56 \end{code}
57
58 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
59 -- place and can be used when complaining.
60
61 The code tree received by the function @rnBinds@ contains definitions
62 in where-clauses which are all apparently mutually recursive, but which may
63 not really depend upon each other. For example, in the top level program
64 \begin{verbatim}
65 f x = y where a = x
66               y = x
67 \end{verbatim}
68 the definitions of @a@ and @y@ do not depend on each other at all.
69 Unfortunately, the typechecker cannot always check such definitions.
70 \footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
71 definitions. In Proceedings of the International Symposium on Programming,
72 Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
73 However, the typechecker usually can check definitions in which only the
74 strongly connected components have been collected into recursive bindings.
75 This is precisely what the function @rnBinds@ does.
76
77 ToDo: deal with case where a single monobinds binds the same variable
78 twice.
79
80 The vertag tag is a unique @Int@; the tags only need to be unique
81 within one @MonoBinds@, so that unique-Int plumbing is done explicitly
82 (heavy monad machinery not needed).
83
84
85 %************************************************************************
86 %*                                                                      *
87 %* naming conventions                                                   *
88 %*                                                                      *
89 %************************************************************************
90
91 \subsection[name-conventions]{Name conventions}
92
93 The basic algorithm involves walking over the tree and returning a tuple
94 containing the new tree plus its free variables. Some functions, such
95 as those walking polymorphic bindings (HsBinds) and qualifier lists in
96 list comprehensions (@Quals@), return the variables bound in local
97 environments. These are then used to calculate the free variables of the
98 expression evaluated in these environments.
99
100 Conventions for variable names are as follows:
101 \begin{itemize}
102 \item
103 new code is given a prime to distinguish it from the old.
104
105 \item
106 a set of variables defined in @Exp@ is written @dvExp@
107
108 \item
109 a set of variables free in @Exp@ is written @fvExp@
110 \end{itemize}
111
112 %************************************************************************
113 %*                                                                      *
114 %* analysing polymorphic bindings (HsBindGroup, HsBind)
115 %*                                                                      *
116 %************************************************************************
117
118 \subsubsection[dep-HsBinds]{Polymorphic bindings}
119
120 Non-recursive expressions are reconstructed without any changes at top
121 level, although their component expressions may have to be altered.
122 However, non-recursive expressions are currently not expected as
123 \Haskell{} programs, and this code should not be executed.
124
125 Monomorphic bindings contain information that is returned in a tuple
126 (a @FlatMonoBinds@) containing:
127
128 \begin{enumerate}
129 \item
130 a unique @Int@ that serves as the ``vertex tag'' for this binding.
131
132 \item
133 the name of a function or the names in a pattern. These are a set
134 referred to as @dvLhs@, the defined variables of the left hand side.
135
136 \item
137 the free variables of the body. These are referred to as @fvBody@.
138
139 \item
140 the definition's actual code. This is referred to as just @code@.
141 \end{enumerate}
142
143 The function @nonRecDvFv@ returns two sets of variables. The first is
144 the set of variables defined in the set of monomorphic bindings, while the
145 second is the set of free variables in those bindings.
146
147 The set of variables defined in a non-recursive binding is just the
148 union of all of them, as @union@ removes duplicates. However, the
149 free variables in each successive set of cumulative bindings is the
150 union of those in the previous set plus those of the newest binding after
151 the defined variables of the previous set have been removed.
152
153 @rnMethodBinds@ deals only with the declarations in class and
154 instance declarations.  It expects only to see @FunMonoBind@s, and
155 it expects the global environment to contain bindings for the binders
156 (which are all class operations).
157
158 %************************************************************************
159 %*                                                                      *
160 \subsubsection{ Top-level bindings}
161 %*                                                                      *
162 %************************************************************************
163
164 \begin{code}
165 -- for top-level bindings, we need to make top-level names,
166 -- so we have a different entry point than for local bindings
167 rnTopBindsLHS :: MiniFixityEnv
168               -> HsValBinds RdrName 
169               -> RnM (HsValBindsLR Name RdrName)
170 rnTopBindsLHS fix_env binds
171   = rnValBindsLHS (topRecNameMaker fix_env) binds
172
173 rnTopBindsRHS :: HsValBindsLR Name RdrName 
174               -> RnM (HsValBinds Name, DefUses)
175 rnTopBindsRHS binds
176   = do { is_boot <- tcIsHsBoot
177        ; if is_boot 
178          then rnTopBindsBoot binds
179          else rnValBindsRHS TopSigCtxt binds }
180
181 rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)
182 -- A hs-boot file has no bindings. 
183 -- Return a single HsBindGroup with empty binds and renamed signatures
184 rnTopBindsBoot (ValBindsIn mbinds sigs)
185   = do  { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
186         ; (sigs', fvs) <- renameSigs HsBootCtxt sigs
187         ; return (ValBindsOut [] sigs', usesOnly fvs) }
188 rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b)
189 \end{code}
190
191
192 %*********************************************************
193 %*                                                      *
194                 HsLocalBinds
195 %*                                                      *
196 %*********************************************************
197
198 \begin{code}
199 rnLocalBindsAndThen :: HsLocalBinds RdrName
200                     -> (HsLocalBinds Name -> RnM (result, FreeVars))
201                     -> RnM (result, FreeVars)
202 -- This version (a) assumes that the binding vars are *not* already in scope
203 --               (b) removes the binders from the free vars of the thing inside
204 -- The parser doesn't produce ThenBinds
205 rnLocalBindsAndThen EmptyLocalBinds thing_inside
206   = thing_inside EmptyLocalBinds
207
208 rnLocalBindsAndThen (HsValBinds val_binds) thing_inside
209   = rnLocalValBindsAndThen val_binds $ \ val_binds' -> 
210       thing_inside (HsValBinds val_binds')
211
212 rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do
213     (binds',fv_binds) <- rnIPBinds binds
214     (thing, fvs_thing) <- thing_inside (HsIPBinds binds')
215     return (thing, fvs_thing `plusFV` fv_binds)
216
217 rnIPBinds :: HsIPBinds RdrName -> RnM (HsIPBinds Name, FreeVars)
218 rnIPBinds (IPBinds ip_binds _no_dict_binds) = do
219     (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds
220     return (IPBinds ip_binds' emptyTcEvBinds, plusFVs fvs_s)
221
222 rnIPBind :: IPBind RdrName -> RnM (IPBind Name, FreeVars)
223 rnIPBind (IPBind n expr) = do
224     n' <- rnIPName n
225     (expr',fvExpr) <- rnLExpr expr
226     return (IPBind n' expr', fvExpr)
227 \end{code}
228
229
230 %************************************************************************
231 %*                                                                      *
232                 ValBinds
233 %*                                                                      *
234 %************************************************************************
235
236 \begin{code}
237 -- Renaming local binding gropus 
238 -- Does duplicate/shadow check
239 rnLocalValBindsLHS :: MiniFixityEnv
240                    -> HsValBinds RdrName
241                    -> RnM ([Name], HsValBindsLR Name RdrName)
242 rnLocalValBindsLHS fix_env binds 
243   = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds 
244
245          -- Check for duplicates and shadowing
246          -- Must do this *after* renaming the patterns
247          -- See Note [Collect binders only after renaming] in HsUtils
248
249          -- We need to check for dups here because we
250          -- don't don't bind all of the variables from the ValBinds at once
251          -- with bindLocatedLocals any more.
252          -- 
253          -- Note that we don't want to do this at the top level, since
254          -- sorting out duplicates and shadowing there happens elsewhere.
255          -- The behavior is even different. For example,
256          --   import A(f)
257          --   f = ...
258          -- should not produce a shadowing warning (but it will produce
259          -- an ambiguity warning if you use f), but
260          --   import A(f)
261          --   g = let f = ... in f
262          -- should.
263        ; let bound_names = collectHsValBinders binds'
264        ; envs <- getRdrEnvs
265        ; checkDupAndShadowedNames envs bound_names
266
267        ; return (bound_names, binds') }
268
269 -- renames the left-hand sides
270 -- generic version used both at the top level and for local binds
271 -- does some error checking, but not what gets done elsewhere at the top level
272 rnValBindsLHS :: NameMaker 
273               -> HsValBinds RdrName
274               -> RnM (HsValBindsLR Name RdrName)
275 rnValBindsLHS topP (ValBindsIn mbinds sigs)
276   = do { mbinds' <- mapBagM (rnBindLHS topP doc) mbinds
277        ; return $ ValBindsIn mbinds' sigs }
278   where
279     bndrs = collectHsBindsBinders mbinds
280     doc   = text "In the binding group for:" <+> pprWithCommas ppr bndrs
281
282 rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)
283
284 -- General version used both from the top-level and for local things
285 -- Assumes the LHS vars are in scope
286 --
287 -- Does not bind the local fixity declarations
288 rnValBindsRHS :: HsSigCtxt 
289               -> HsValBindsLR Name RdrName
290               -> RnM (HsValBinds Name, DefUses)
291
292 rnValBindsRHS ctxt (ValBindsIn mbinds sigs)
293   = do { (sigs', sig_fvs) <- renameSigs ctxt sigs
294        ; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs')) mbinds
295        ; case depAnalBinds binds_w_dus of
296            (anal_binds, anal_dus) -> return (valbind', valbind'_dus)
297               where
298                 valbind' = ValBindsOut anal_binds sigs'
299                 valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs
300                                -- Put the sig uses *after* the bindings
301                                -- so that the binders are removed from 
302                                -- the uses in the sigs
303        }
304
305 rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b)
306
307 -- Wrapper for local binds
308 --
309 -- The *client* of this function is responsible for checking for unused binders;
310 -- it doesn't (and can't: we don't have the thing inside the binds) happen here
311 --
312 -- The client is also responsible for bringing the fixities into scope
313 rnLocalValBindsRHS :: NameSet  -- names bound by the LHSes
314                    -> HsValBindsLR Name RdrName
315                    -> RnM (HsValBinds Name, DefUses)
316 rnLocalValBindsRHS bound_names binds
317   = rnValBindsRHS (LocalBindCtxt bound_names) binds
318
319 -- for local binds
320 -- wrapper that does both the left- and right-hand sides 
321 --
322 -- here there are no local fixity decls passed in;
323 -- the local fixity decls come from the ValBinds sigs
324 rnLocalValBindsAndThen :: HsValBinds RdrName
325                        -> (HsValBinds Name -> RnM (result, FreeVars))
326                        -> RnM (result, FreeVars)
327 rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside
328  = do   {     -- (A) Create the local fixity environment 
329           new_fixities <- makeMiniFixityEnv [L loc sig | L loc (FixSig sig) <- sigs]
330
331               -- (B) Rename the LHSes 
332         ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds
333
334               --     ...and bring them (and their fixities) into scope
335         ; bindLocalNamesFV bound_names              $
336           addLocalFixities new_fixities bound_names $ do
337
338         {      -- (C) Do the RHS and thing inside
339           (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs 
340         ; (result, result_fvs) <- thing_inside binds'
341
342                 -- Report unused bindings based on the (accurate) 
343                 -- findUses.  E.g.
344                 --      let x = x in 3
345                 -- should report 'x' unused
346         ; let real_uses = findUses dus result_fvs
347               -- Insert fake uses for variables introduced implicitly by wildcards (#4404)
348               implicit_uses = hsValBindsImplicits binds'
349         ; warnUnusedLocalBinds bound_names (real_uses `unionNameSets` implicit_uses)
350
351         ; let
352             -- The variables "used" in the val binds are: 
353             --   (1) the uses of the binds (allUses)
354             --   (2) the FVs of the thing-inside
355             all_uses = allUses dus `plusFV` result_fvs
356                 -- Note [Unused binding hack]
357                 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~
358                 -- Note that *in contrast* to the above reporting of
359                 -- unused bindings, (1) above uses duUses to return *all* 
360                 -- the uses, even if the binding is unused.  Otherwise consider:
361                 --      x = 3
362                 --      y = let p = x in 'x'    -- NB: p not used
363                 -- If we don't "see" the dependency of 'y' on 'x', we may put the
364                 -- bindings in the wrong order, and the type checker will complain
365                 -- that x isn't in scope
366                 --
367                 -- But note that this means we won't report 'x' as unused, 
368                 -- whereas we would if we had { x = 3; p = x; y = 'x' }
369
370         ; return (result, all_uses) }}
371                 -- The bound names are pruned out of all_uses
372                 -- by the bindLocalNamesFV call above
373
374 rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs)
375
376
377 -- Process the fixity declarations, making a FastString -> (Located Fixity) map
378 -- (We keep the location around for reporting duplicate fixity declarations.)
379 -- 
380 -- Checks for duplicates, but not that only locally defined things are fixed.
381 -- Note: for local fixity declarations, duplicates would also be checked in
382 --       check_sigs below.  But we also use this function at the top level.
383
384 makeMiniFixityEnv :: [LFixitySig RdrName] -> RnM MiniFixityEnv
385
386 makeMiniFixityEnv decls = foldlM add_one emptyFsEnv decls
387  where
388    add_one env (L loc (FixitySig (L name_loc name) fixity)) = do
389      { -- this fixity decl is a duplicate iff
390        -- the ReaderName's OccName's FastString is already in the env
391        -- (we only need to check the local fix_env because
392        --  definitions of non-local will be caught elsewhere)
393        let { fs = occNameFS (rdrNameOcc name)
394            ; fix_item = L loc fixity };
395
396        case lookupFsEnv env fs of
397          Nothing -> return $ extendFsEnv env fs fix_item
398          Just (L loc' _) -> do
399            { setSrcSpan loc $ 
400              addErrAt name_loc (dupFixityDecl loc' name)
401            ; return env}
402      }
403
404 dupFixityDecl :: SrcSpan -> RdrName -> SDoc
405 dupFixityDecl loc rdr_name
406   = vcat [ptext (sLit "Multiple fixity declarations for") <+> quotes (ppr rdr_name),
407           ptext (sLit "also at ") <+> ppr loc]
408
409 ---------------------
410
411 -- renaming a single bind
412
413 rnBindLHS :: NameMaker
414           -> SDoc 
415           -> LHsBind RdrName
416           -- returns the renamed left-hand side,
417           -- and the FreeVars *of the LHS*
418           -- (i.e., any free variables of the pattern)
419           -> RnM (LHsBindLR Name RdrName)
420
421 rnBindLHS name_maker _ (L loc bind@(PatBind { pat_lhs = pat }))
422   = setSrcSpan loc $ do
423       -- we don't actually use the FV processing of rnPatsAndThen here
424       (pat',pat'_fvs) <- rnBindPat name_maker pat
425       return (L loc (bind { pat_lhs = pat', bind_fvs = pat'_fvs }))
426                 -- We temporarily store the pat's FVs in bind_fvs;
427                 -- gets updated to the FVs of the whole bind
428                 -- when doing the RHS below
429                             
430 rnBindLHS name_maker _ (L loc bind@(FunBind { fun_id = name@(L nameLoc _) }))
431   = setSrcSpan loc $ 
432     do { newname <- applyNameMaker name_maker name
433        ; return (L loc (bind { fun_id = L nameLoc newname })) } 
434
435 rnBindLHS _ _ b = pprPanic "rnBindLHS" (ppr b)
436
437 -- assumes the left-hands-side vars are in scope
438 rnBind :: (Name -> [Name])              -- Signature tyvar function
439        -> LHsBindLR Name RdrName
440        -> RnM (LHsBind Name, [Name], Uses)
441 rnBind _ (L loc bind@(PatBind { pat_lhs = pat
442                               , pat_rhs = grhss 
443                                       -- pat fvs were stored in bind_fvs
444                                       -- after processing the LHS
445                               , bind_fvs = pat_fvs }))
446   = setSrcSpan loc $ 
447     do  { mod <- getModule
448         ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs grhss
449
450                 -- No scoped type variables for pattern bindings
451         ; let all_fvs = pat_fvs `plusFV` rhs_fvs
452               fvs'    = filterNameSet (nameIsLocalOrFrom mod) all_fvs
453                 -- Keep locally-defined Names
454                 -- As well as dependency analysis, we need these for the
455                 -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
456
457         ; fvs' `seq` -- See Note [Free-variable space leak]
458           return (L loc (bind { pat_rhs  = grhss' 
459                               , bind_fvs = fvs' }),
460                   collectPatBinders pat, all_fvs) }
461
462 rnBind sig_fn (L loc bind@(FunBind { fun_id = name 
463                                    , fun_infix = is_infix 
464                                    , fun_matches = matches })) 
465        -- invariant: no free vars here when it's a FunBind
466   = setSrcSpan loc $
467     do  { let plain_name = unLoc name
468
469         ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
470                                 -- bindSigTyVars tests for Opt_ScopedTyVars
471                                  rnMatchGroup (FunRhs plain_name is_infix) matches
472         ; when is_infix $ checkPrecMatch plain_name matches'
473
474         ; mod <- getModule
475         ; let fvs' = filterNameSet (nameIsLocalOrFrom mod) rhs_fvs
476                 -- Keep locally-defined Names
477                 -- As well as dependency analysis, we need these for the
478                 -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
479
480         ; fvs' `seq` -- See Note [Free-variable space leak]
481           return (L loc (bind { fun_matches = matches'
482                               , bind_fvs   = fvs' }), 
483                   [plain_name], rhs_fvs)
484       }
485
486 rnBind _ b = pprPanic "rnBind" (ppr b)
487
488 {-
489 Note [Free-variable space leak]
490 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
491 We have
492     fvs' = trim fvs
493 and we seq fvs' before turning it as part of a record.
494
495 The reason is that trim is sometimes something like
496     \xs -> intersectNameSet (mkNameSet bound_names) xs
497 and we don't want to retain the list bound_names. This showed up in
498 trac ticket #1136.
499 -}
500
501 ---------------------
502 depAnalBinds :: Bag (LHsBind Name, [Name], Uses)
503              -> ([(RecFlag, LHsBinds Name)], DefUses)
504 -- Dependency analysis; this is important so that 
505 -- unused-binding reporting is accurate
506 depAnalBinds binds_w_dus
507   = (map get_binds sccs, map get_du sccs)
508   where
509     sccs = stronglyConnCompFromEdgedVertices edges
510
511     keyd_nodes = bagToList binds_w_dus `zip` [0::Int ..]
512
513     edges = [ (node, key, [key | n <- nameSetToList uses,
514                                  Just key <- [lookupNameEnv key_map n] ])
515             | (node@(_,_,uses), key) <- keyd_nodes ]
516
517     key_map :: NameEnv Int      -- Which binding it comes from
518     key_map = mkNameEnv [(bndr, key) | ((_, bndrs, _), key) <- keyd_nodes
519                                      , bndr <- bndrs ]
520
521     get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind)
522     get_binds (CyclicSCC  binds_w_dus)  = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus])
523
524     get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses)
525     get_du (CyclicSCC  binds_w_dus)      = (Just defs, uses)
526         where
527           defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs]
528           uses = unionManyNameSets [u | (_,_,u) <- binds_w_dus]
529
530
531 ---------------------
532 -- Bind the top-level forall'd type variables in the sigs.
533 -- E.g  f :: a -> a
534 --      f = rhs
535 --      The 'a' scopes over the rhs
536 --
537 -- NB: there'll usually be just one (for a function binding)
538 --     but if there are many, one may shadow the rest; too bad!
539 --      e.g  x :: [a] -> [a]
540 --           y :: [(a,a)] -> a
541 --           (x,y) = e
542 --      In e, 'a' will be in scope, and it'll be the one from 'y'!
543
544 mkSigTvFn :: [LSig Name] -> (Name -> [Name])
545 -- Return a lookup function that maps an Id Name to the names
546 -- of the type variables that should scope over its body..
547 mkSigTvFn sigs
548   = \n -> lookupNameEnv env n `orElse` []
549   where
550     env :: NameEnv [Name]
551     env = mkNameEnv [ (name, map hsLTyVarName ltvs)
552                     | L _ (TypeSig names
553                                    (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs
554                     , (L _ name) <- names]
555         -- Note the pattern-match on "Explicit"; we only bind
556         -- type variables from signatures with an explicit top-level for-all
557 \end{code}
558
559
560 @rnMethodBinds@ is used for the method bindings of a class and an instance
561 declaration.   Like @rnBinds@ but without dependency analysis.
562
563 NOTA BENE: we record each {\em binder} of a method-bind group as a free variable.
564 That's crucial when dealing with an instance decl:
565 \begin{verbatim}
566         instance Foo (T a) where
567            op x = ...
568 \end{verbatim}
569 This might be the {\em sole} occurrence of @op@ for an imported class @Foo@,
570 and unless @op@ occurs we won't treat the type signature of @op@ in the class
571 decl for @Foo@ as a source of instance-decl gates.  But we should!  Indeed,
572 in many ways the @op@ in an instance decl is just like an occurrence, not
573 a binder.
574
575 \begin{code}
576 rnMethodBinds :: Name                   -- Class name
577               -> (Name -> [Name])       -- Signature tyvar function
578               -> LHsBinds RdrName
579               -> RnM (LHsBinds Name, FreeVars)
580
581 rnMethodBinds cls sig_fn binds
582   = do { checkDupRdrNames meth_names
583              -- Check that the same method is not given twice in the
584              -- same instance decl      instance C T where
585              --                       f x = ...
586              --                       g y = ...
587              --                       f x = ...
588              -- We must use checkDupRdrNames because the Name of the
589              -- method is the Name of the class selector, whose SrcSpan
590              -- points to the class declaration; and we use rnMethodBinds
591              -- for instance decls too
592
593        ; foldlM do_one (emptyBag, emptyFVs) (bagToList binds) }
594   where 
595     meth_names  = collectMethodBinders binds
596     do_one (binds,fvs) bind 
597        = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn bind
598             ; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) }
599
600 rnMethodBind :: Name
601               -> (Name -> [Name])
602               -> LHsBindLR RdrName RdrName
603               -> RnM (Bag (LHsBindLR Name Name), FreeVars)
604 rnMethodBind cls sig_fn 
605              (L loc bind@(FunBind { fun_id = name, fun_infix = is_infix 
606                                   , fun_matches = MatchGroup matches _ }))
607   = setSrcSpan loc $ do
608     sel_name <- wrapLocM (lookupInstDeclBndr cls (ptext (sLit "method"))) name
609     let plain_name = unLoc sel_name
610         -- We use the selector name as the binder
611
612     (new_matches, fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
613                           mapFvRn (rnMatch (FunRhs plain_name is_infix)) matches
614     let new_group = MatchGroup new_matches placeHolderType
615
616     when is_infix $ checkPrecMatch plain_name new_group
617     return (unitBag (L loc (bind { fun_id      = sel_name 
618                                  , fun_matches = new_group
619                                  , bind_fvs    = fvs })),
620              fvs `addOneFV` plain_name)
621         -- The 'fvs' field isn't used for method binds
622
623 -- Can't handle method pattern-bindings which bind multiple methods.
624 rnMethodBind _ _ (L loc bind@(PatBind {})) = do
625     addErrAt loc (methodBindErr bind)
626     return (emptyBag, emptyFVs)
627
628 rnMethodBind _ _ b = pprPanic "rnMethodBind" (ppr b)
629 \end{code}
630
631
632
633 %************************************************************************
634 %*                                                                      *
635 \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
636 %*                                                                      *
637 %************************************************************************
638
639 @renameSigs@ checks for:
640 \begin{enumerate}
641 \item more than one sig for one thing;
642 \item signatures given for things not bound here;
643 \end{enumerate}
644 %
645 At the moment we don't gather free-var info from the types in
646 signatures.  We'd only need this if we wanted to report unused tyvars.
647
648 \begin{code}
649 renameSigs :: HsSigCtxt 
650            -> [LSig RdrName]
651            -> RnM ([LSig Name], FreeVars)
652 -- Renames the signatures and performs error checks
653 renameSigs ctxt sigs 
654   = do  { mapM_ dupSigDeclErr (findDupsEq overlapHsSig sigs)  -- Duplicate
655                 -- Check for duplicates on RdrName version, 
656                 -- because renamed version has unboundName for
657                 -- not-in-scope binders, which gives bogus dup-sig errors
658                 -- NB: in a class decl, a 'generic' sig is not considered 
659                 --     equal to an ordinary sig, so we allow, say
660                 --           class C a where
661                 --             op :: a -> a
662                 --             default op :: Eq a => a -> a
663                 
664         ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs
665
666         ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs'
667         ; mapM_ misplacedSigErr bad_sigs                 -- Misplaced
668
669         ; return (good_sigs, sig_fvs) } 
670
671 ----------------------
672 -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
673 -- because this won't work for:
674 --      instance Foo T where
675 --        {-# INLINE op #-}
676 --        Baz.op = ...
677 -- We'll just rename the INLINE prag to refer to whatever other 'op'
678 -- is in scope.  (I'm assuming that Baz.op isn't in scope unqualified.)
679 -- Doesn't seem worth much trouble to sort this.
680
681 renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name, FreeVars)
682 -- FixitySig is renamed elsewhere.
683 renameSig _ (IdSig x)
684   = return (IdSig x, emptyFVs)    -- Actually this never occurs
685
686 renameSig ctxt sig@(TypeSig vs ty)
687   = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
688         ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty
689         ; return (TypeSig new_vs new_ty, fvs) }
690
691 renameSig ctxt sig@(GenericSig vs ty)
692   = do  { defaultSigs_on <- xoptM Opt_DefaultSignatures
693         ; unless defaultSigs_on (addErr (defaultSigErr sig))
694         ; new_v <- mapM (lookupSigOccRn ctxt sig) vs
695         ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty
696         ; return (GenericSig new_v new_ty, fvs) }
697
698 renameSig _ (SpecInstSig ty)
699   = do  { (new_ty, fvs) <- rnLHsType SpecInstSigCtx ty
700         ; return (SpecInstSig new_ty,fvs) }
701
702 -- {-# SPECIALISE #-} pragmas can refer to imported Ids
703 -- so, in the top-level case (when mb_names is Nothing)
704 -- we use lookupOccRn.  If there's both an imported and a local 'f'
705 -- then the SPECIALISE pragma is ambiguous, unlike all other signatures
706 renameSig ctxt sig@(SpecSig v ty inl)
707   = do  { new_v <- case ctxt of 
708                      TopSigCtxt -> lookupLocatedOccRn v
709                      _          -> lookupSigOccRn ctxt sig v
710         ; (new_ty, fvs) <- rnHsSigType (quotes (ppr v)) ty
711         ; return (SpecSig new_v new_ty inl, fvs) }
712
713 renameSig ctxt sig@(InlineSig v s)
714   = do  { new_v <- lookupSigOccRn ctxt sig v
715         ; return (InlineSig new_v s, emptyFVs) }
716
717 renameSig ctxt sig@(FixSig (FixitySig v f))
718   = do  { new_v <- lookupSigOccRn ctxt sig v
719         ; return (FixSig (FixitySig new_v f), emptyFVs) }
720
721 ppr_sig_bndrs :: [Located RdrName] -> SDoc
722 ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
723
724 okHsSig :: HsSigCtxt -> LSig a -> Bool
725 okHsSig ctxt (L _ sig) 
726   = case (sig, ctxt) of
727      (GenericSig {}, ClsDeclCtxt {}) -> True
728      (GenericSig {}, _)              -> False
729
730      (TypeSig {}, _)              -> True
731
732      (FixSig {}, InstDeclCtxt {}) -> False
733      (FixSig {}, _)               -> True
734
735      (IdSig {}, TopSigCtxt)      -> True
736      (IdSig {}, InstDeclCtxt {}) -> True
737      (IdSig {}, _)               -> False
738
739      (InlineSig {}, HsBootCtxt) -> False
740      (InlineSig {}, _)          -> True
741
742      (SpecSig {}, TopSigCtxt)       -> True
743      (SpecSig {}, LocalBindCtxt {}) -> True
744      (SpecSig {}, InstDeclCtxt {})  -> True
745      (SpecSig {}, _)                -> False
746
747      (SpecInstSig {}, InstDeclCtxt {}) -> True
748      (SpecInstSig {}, _)               -> False
749 \end{code}
750
751
752 %************************************************************************
753 %*                                                                      *
754 \subsection{Match}
755 %*                                                                      *
756 %************************************************************************
757
758 \begin{code}
759 rnMatchGroup :: HsMatchContext Name -> MatchGroup RdrName -> RnM (MatchGroup Name, FreeVars)
760 rnMatchGroup ctxt (MatchGroup ms _) 
761   = do { (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt) ms
762        ; return (MatchGroup new_ms placeHolderType, ms_fvs) }
763
764 rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars)
765 rnMatch ctxt  = wrapLocFstM (rnMatch' ctxt)
766
767 rnMatch' :: HsMatchContext Name -> Match RdrName -> RnM (Match Name, FreeVars)
768 rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss)
769   = do  {       -- Result type signatures are no longer supported
770           case maybe_rhs_sig of 
771                 Nothing -> return ()
772                 Just (L loc ty) -> addErrAt loc (resSigErr ctxt match ty)
773
774                -- Now the main event
775                -- note that there are no local ficity decls for matches
776         ; rnPats ctxt pats      $ \ pats' -> do
777         { (grhss', grhss_fvs) <- rnGRHSs ctxt grhss
778
779         ; return (Match pats' Nothing grhss', grhss_fvs) }}
780
781 resSigErr :: HsMatchContext Name -> Match RdrName -> HsType RdrName -> SDoc 
782 resSigErr ctxt match ty
783    = vcat [ ptext (sLit "Illegal result type signature") <+> quotes (ppr ty)
784           , nest 2 $ ptext (sLit "Result signatures are no longer supported in pattern matches")
785           , pprMatchInCtxt ctxt match ]
786 \end{code}
787
788
789 %************************************************************************
790 %*                                                                      *
791 \subsubsection{Guarded right-hand sides (GRHSs)}
792 %*                                                                      *
793 %************************************************************************
794
795 \begin{code}
796 rnGRHSs :: HsMatchContext Name -> GRHSs RdrName -> RnM (GRHSs Name, FreeVars)
797
798 rnGRHSs ctxt (GRHSs grhss binds)
799   = rnLocalBindsAndThen binds   $ \ binds' -> do
800     (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt) grhss
801     return (GRHSs grhss' binds', fvGRHSs)
802
803 rnGRHS :: HsMatchContext Name -> LGRHS RdrName -> RnM (LGRHS Name, FreeVars)
804 rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt)
805
806 rnGRHS' :: HsMatchContext Name -> GRHS RdrName -> RnM (GRHS Name, FreeVars)
807 rnGRHS' ctxt (GRHS guards rhs)
808   = do  { pattern_guards_allowed <- xoptM Opt_PatternGuards
809         ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $ \ _ ->
810                                     rnLExpr rhs
811
812         ; unless (pattern_guards_allowed || is_standard_guard guards')
813                  (addWarn (nonStdGuardErr guards'))
814
815         ; return (GRHS guards' rhs', fvs) }
816   where
817         -- Standard Haskell 1.4 guards are just a single boolean
818         -- expression, rather than a list of qualifiers as in the
819         -- Glasgow extension
820     is_standard_guard []                       = True
821     is_standard_guard [L _ (ExprStmt _ _ _ _)] = True
822     is_standard_guard _                        = False
823 \end{code}
824
825 %************************************************************************
826 %*                                                                      *
827 \subsection{Error messages}
828 %*                                                                      *
829 %************************************************************************
830
831 \begin{code}
832 dupSigDeclErr :: [LSig RdrName] -> RnM ()
833 dupSigDeclErr sigs@(L loc sig : _)
834   = addErrAt loc $
835         vcat [ptext (sLit "Duplicate") <+> what_it_is <> colon,
836               nest 2 (vcat (map ppr_sig sigs))]
837   where
838     what_it_is = hsSigDoc sig
839     ppr_sig (L loc sig) = ppr loc <> colon <+> ppr sig
840 dupSigDeclErr [] = panic "dupSigDeclErr"
841
842 misplacedSigErr :: LSig Name -> RnM ()
843 misplacedSigErr (L loc sig)
844   = addErrAt loc $
845     sep [ptext (sLit "Misplaced") <+> hsSigDoc sig <> colon, ppr sig]
846
847 defaultSigErr :: Sig RdrName -> SDoc
848 defaultSigErr sig = vcat [ hang (ptext (sLit "Unexpected default signature:"))
849                               2 (ppr sig)
850                          , ptext (sLit "Use -XDefaultSignatures to enable default signatures") ] 
851
852 methodBindErr :: HsBindLR RdrName RdrName -> SDoc
853 methodBindErr mbind
854  =  hang (ptext (sLit "Pattern bindings (except simple variables) not allowed in instance declarations"))
855        2 (ppr mbind)
856
857 bindsInHsBootFile :: LHsBindsLR Name RdrName -> SDoc
858 bindsInHsBootFile mbinds
859   = hang (ptext (sLit "Bindings in hs-boot files are not allowed"))
860        2 (ppr mbinds)
861
862 nonStdGuardErr :: [LStmtLR Name Name] -> SDoc
863 nonStdGuardErr guards
864   = hang (ptext (sLit "accepting non-standard pattern guards (use -XPatternGuards to suppress this message)"))
865        4 (interpp'SP guards)
866
867 \end{code}