2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[RnBinds]{Renaming and dependency analysis of bindings}
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).
13 rnTopBinds, rnTopMonoBinds,
14 rnMethodBinds, renameSigs,
18 #include "HsVersions.h"
20 import {-# SOURCE #-} RnSource ( rnHsSigType )
23 import HsBinds ( sigsForMe )
27 import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch )
28 import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, lookupGlobalOccRn,
29 isUnboundName, warnUnusedLocalBinds,
30 FreeVars, emptyFVs, plusFV, plusFVs, unitFV
32 import CmdLineOpts ( opt_WarnMissingSigs )
33 import Digraph ( stronglyConnComp, SCC(..) )
34 import Name ( OccName, Name )
36 import BasicTypes ( RecFlag(..), TopLevelFlag(..) )
37 import Util ( thenCmp, removeDups )
38 import ListSetOps ( minusList )
39 import Bag ( bagToList )
43 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
44 -- place and can be used when complaining.
46 The code tree received by the function @rnBinds@ contains definitions
47 in where-clauses which are all apparently mutually recursive, but which may
48 not really depend upon each other. For example, in the top level program
53 the definitions of @a@ and @y@ do not depend on each other at all.
54 Unfortunately, the typechecker cannot always check such definitions.
55 \footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
56 definitions. In Proceedings of the International Symposium on Programming,
57 Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
58 However, the typechecker usually can check definitions in which only the
59 strongly connected components have been collected into recursive bindings.
60 This is precisely what the function @rnBinds@ does.
62 ToDo: deal with case where a single monobinds binds the same variable
65 The vertag tag is a unique @Int@; the tags only need to be unique
66 within one @MonoBinds@, so that unique-Int plumbing is done explicitly
67 (heavy monad machinery not needed).
71 type Cycle = [VertexTag]
72 type Edge = (VertexTag, VertexTag)
75 %************************************************************************
77 %* naming conventions *
79 %************************************************************************
81 \subsection[name-conventions]{Name conventions}
83 The basic algorithm involves walking over the tree and returning a tuple
84 containing the new tree plus its free variables. Some functions, such
85 as those walking polymorphic bindings (HsBinds) and qualifier lists in
86 list comprehensions (@Quals@), return the variables bound in local
87 environments. These are then used to calculate the free variables of the
88 expression evaluated in these environments.
90 Conventions for variable names are as follows:
93 new code is given a prime to distinguish it from the old.
96 a set of variables defined in @Exp@ is written @dvExp@
99 a set of variables free in @Exp@ is written @fvExp@
102 %************************************************************************
104 %* analysing polymorphic bindings (HsBinds, Bind, MonoBinds) *
106 %************************************************************************
108 \subsubsection[dep-HsBinds]{Polymorphic bindings}
110 Non-recursive expressions are reconstructed without any changes at top
111 level, although their component expressions may have to be altered.
112 However, non-recursive expressions are currently not expected as
113 \Haskell{} programs, and this code should not be executed.
115 Monomorphic bindings contain information that is returned in a tuple
116 (a @FlatMonoBindsInfo@) containing:
120 a unique @Int@ that serves as the ``vertex tag'' for this binding.
123 the name of a function or the names in a pattern. These are a set
124 referred to as @dvLhs@, the defined variables of the left hand side.
127 the free variables of the body. These are referred to as @fvBody@.
130 the definition's actual code. This is referred to as just @code@.
133 The function @nonRecDvFv@ returns two sets of variables. The first is
134 the set of variables defined in the set of monomorphic bindings, while the
135 second is the set of free variables in those bindings.
137 The set of variables defined in a non-recursive binding is just the
138 union of all of them, as @union@ removes duplicates. However, the
139 free variables in each successive set of cumulative bindings is the
140 union of those in the previous set plus those of the newest binding after
141 the defined variables of the previous set have been removed.
143 @rnMethodBinds@ deals only with the declarations in class and
144 instance declarations. It expects only to see @FunMonoBind@s, and
145 it expects the global environment to contain bindings for the binders
146 (which are all class operations).
148 %************************************************************************
150 %* Top-level bindings
152 %************************************************************************
154 @rnTopBinds@ assumes that the environment already
155 contains bindings for the binders of this particular binding.
158 rnTopBinds :: RdrNameHsBinds -> RnMS s (RenamedHsBinds, FreeVars)
160 rnTopBinds EmptyBinds = returnRn (EmptyBinds, emptyFVs)
161 rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs
162 -- The parser doesn't produce other forms
165 rnTopMonoBinds EmptyMonoBinds sigs
166 = returnRn (EmptyBinds, emptyFVs)
168 rnTopMonoBinds mbinds sigs
169 = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names ->
171 binder_set = mkNameSet binder_names
173 rn_mono_binds TopLevel binder_set mbinds sigs
175 binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds))
178 %************************************************************************
182 %************************************************************************
185 - collects up the binders for this declaration group,
186 - checks that they form a set
187 - extends the environment to bind them to new local names
188 - calls @rnMonoBinds@ to do the real work
191 rnBinds :: RdrNameHsBinds
192 -> (RenamedHsBinds -> RnMS s (result, FreeVars))
193 -> RnMS s (result, FreeVars)
195 rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds
196 rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside
197 -- the parser doesn't produce other forms
200 rnMonoBinds :: RdrNameMonoBinds -> [RdrNameSig]
201 -> (RenamedHsBinds -> RnMS s (result, FreeVars))
202 -> RnMS s (result, FreeVars)
204 rnMonoBinds EmptyMonoBinds sigs thing_inside = thing_inside EmptyBinds
206 rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds
207 = -- Extract all the binders in this group,
208 -- and extend current scope, inventing new names for the new binders
209 -- This also checks that the names form a set
210 bindLocatedLocalsRn (text "binding group") mbinders_w_srclocs $ \ new_mbinders ->
212 binder_set = mkNameSet new_mbinders
214 rn_mono_binds NotTopLevel
215 binder_set mbinds sigs `thenRn` \ (binds,bind_fvs) ->
217 -- Now do the "thing inside", and deal with the free-variable calculations
218 thing_inside binds `thenRn` \ (result,result_fvs) ->
220 all_fvs = result_fvs `plusFV` bind_fvs
221 unused_binders = nameSetToList (binder_set `minusNameSet` all_fvs)
223 warnUnusedLocalBinds unused_binders `thenRn_`
224 returnRn (result, delListFromNameSet all_fvs new_mbinders)
226 mbinders_w_srclocs = bagToList (collectMonoBinders mbinds)
230 %************************************************************************
232 %* MonoBinds -- the main work is done here
234 %************************************************************************
236 @rnMonoBinds@ is used by *both* top-level and nested bindings. It
237 assumes that all variables bound in this group are already in scope.
238 This is done *either* by pass 3 (for the top-level bindings), *or* by
239 @rnNestedMonoBinds@ (for the nested ones).
242 rn_mono_binds :: TopLevelFlag
243 -> NameSet -- Binders of this group
245 -> [RdrNameSig] -- Signatures attached to this group
246 -> RnMS s (RenamedHsBinds, --
247 FreeVars) -- Free variables
249 rn_mono_binds top_lev binders mbinds sigs
251 -- Rename the bindings, returning a MonoBindsInfo
252 -- which is a list of indivisible vertices so far as
253 -- the strongly-connected-components (SCC) analysis is concerned
254 renameSigs top_lev False binders sigs `thenRn` \ (siglist, sig_fvs) ->
255 flattenMonoBinds siglist mbinds `thenRn` \ mbinds_info ->
257 -- Do the SCC analysis
258 let edges = mkEdges (mbinds_info `zip` [(0::Int)..])
259 scc_result = stronglyConnComp edges
260 final_binds = foldr1 ThenBinds (map reconstructCycle scc_result)
262 -- Deal with bound and free-var calculation
263 rhs_fvs = plusFVs [fvs | (_,fvs,_,_) <- mbinds_info]
265 returnRn (final_binds, rhs_fvs `plusFV` sig_fvs)
268 @flattenMonoBinds@ is ever-so-slightly magical in that it sticks
269 unique ``vertex tags'' on its output; minor plumbing required.
272 flattenMonoBinds :: [RenamedSig] -- Signatures
274 -> RnMS s [FlatMonoBindsInfo]
276 flattenMonoBinds sigs EmptyMonoBinds = returnRn []
278 flattenMonoBinds sigs (AndMonoBinds bs1 bs2)
279 = flattenMonoBinds sigs bs1 `thenRn` \ flat1 ->
280 flattenMonoBinds sigs bs2 `thenRn` \ flat2 ->
281 returnRn (flat1 ++ flat2)
283 flattenMonoBinds sigs (PatMonoBind pat grhss locn)
284 = pushSrcLocRn locn $
285 rnPat pat `thenRn` \ (pat', pat_fvs) ->
287 -- Find which things are bound in this group
289 names_bound_here = mkNameSet (collectPatBinders pat')
290 sigs_for_me = sigsForMe (`elemNameSet` names_bound_here) sigs
291 sigs_fvs = foldr sig_fv emptyFVs sigs_for_me
292 fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- sigs_for_me]
294 extendFixityEnv fixity_sigs $
295 rnGRHSs grhss `thenRn` \ (grhss', fvs) ->
298 fvs `plusFV` sigs_fvs `plusFV` pat_fvs,
299 PatMonoBind pat' grhss' locn,
303 flattenMonoBinds sigs (FunMonoBind name inf matches locn)
304 = pushSrcLocRn locn $
305 lookupBndrRn name `thenRn` \ name' ->
307 sigs_for_me = sigsForMe (name' ==) sigs
308 sigs_fvs = foldr sig_fv emptyFVs sigs_for_me
309 fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- sigs_for_me]
311 extendFixityEnv fixity_sigs $
312 mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) ->
313 mapRn (checkPrecMatch inf name') new_matches `thenRn_`
316 plusFVs fv_lists `plusFV` sigs_fvs,
317 FunMonoBind name' inf new_matches locn,
323 @rnMethodBinds@ is used for the method bindings of an instance
324 declaration. like @rnMonoBinds@ but without dependency analysis.
327 rnMethodBinds :: RdrNameMonoBinds -> RnMS s (RenamedMonoBinds, FreeVars)
329 rnMethodBinds EmptyMonoBinds = returnRn (EmptyMonoBinds, emptyFVs)
331 rnMethodBinds (AndMonoBinds mb1 mb2)
332 = rnMethodBinds mb1 `thenRn` \ (mb1', fvs1) ->
333 rnMethodBinds mb2 `thenRn` \ (mb2', fvs2) ->
334 returnRn (mb1' `AndMonoBinds` mb2', fvs1 `plusFV` fvs2)
336 rnMethodBinds (FunMonoBind name inf matches locn)
337 = pushSrcLocRn locn $
339 lookupGlobalOccRn name `thenRn` \ sel_name ->
340 -- We use the selector name as the binder
342 mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fvs_s) ->
343 mapRn (checkPrecMatch inf sel_name) new_matches `thenRn_`
344 returnRn (FunMonoBind sel_name inf new_matches locn, plusFVs fvs_s)
346 rnMethodBinds (PatMonoBind (VarPatIn name) grhss locn)
347 = pushSrcLocRn locn $
348 lookupGlobalOccRn name `thenRn` \ sel_name ->
349 rnGRHSs grhss `thenRn` \ (grhss', fvs) ->
350 returnRn (PatMonoBind (VarPatIn sel_name) grhss' locn, fvs)
352 -- Can't handle method pattern-bindings which bind multiple methods.
353 rnMethodBinds mbind@(PatMonoBind other_pat _ locn)
354 = pushSrcLocRn locn $
355 failWithRn (EmptyMonoBinds, emptyFVs) (methodBindErr mbind)
359 -- If a SPECIALIZE pragma is of the "... = blah" form,
360 -- then we'd better make sure "blah" is taken into
361 -- acct in the dependency analysis (or we get an
362 -- unexpected out-of-scope error)! WDP 95/07
364 -- This is only necessary for the dependency analysis. The free vars
365 -- of the types in the signatures is gotten from renameSigs
367 sig_fv (SpecSig _ _ (Just blah) _) acc = acc `plusFV` unitFV blah
371 %************************************************************************
373 \subsection[reconstruct-deps]{Reconstructing dependencies}
375 %************************************************************************
377 This @MonoBinds@- and @ClassDecls@-specific code is segregated here,
378 as the two cases are similar.
381 reconstructCycle :: SCC FlatMonoBindsInfo
384 reconstructCycle (AcyclicSCC (_, _, binds, sigs))
385 = MonoBind binds sigs NonRecursive
387 reconstructCycle (CyclicSCC cycle)
388 = MonoBind this_gp_binds this_gp_sigs Recursive
390 this_gp_binds = foldr1 AndMonoBinds [binds | (_, _, binds, _) <- cycle]
391 this_gp_sigs = foldr1 (++) [sigs | (_, _, _, sigs) <- cycle]
394 %************************************************************************
396 %* Manipulating FlatMonoBindInfo *
398 %************************************************************************
400 During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@.
401 The @RenamedMonoBinds@ is always an empty bind, a pattern binding or
402 a function binding, and has itself been dependency-analysed and
406 type FlatMonoBindsInfo
407 = (NameSet, -- Set of names defined in this vertex
408 NameSet, -- Set of names used in this vertex
410 [RenamedSig]) -- Signatures, if any, for this vertex
412 mkEdges :: [(FlatMonoBindsInfo, VertexTag)] -> [(FlatMonoBindsInfo, VertexTag, [VertexTag])]
415 = [ (info, tag, dest_vertices (nameSetToList names_used))
416 | (info@(names_defined, names_used, mbind, sigs), tag) <- flat_info
419 -- An edge (v,v') indicates that v depends on v'
420 dest_vertices src_mentions = [ target_vertex
421 | ((names_defined, _, _, _), target_vertex) <- flat_info,
422 mentioned_name <- src_mentions,
423 mentioned_name `elemNameSet` names_defined
428 %************************************************************************
430 \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
432 %************************************************************************
434 @renameSigs@ checks for: (a)~more than one sig for one thing;
435 (b)~signatures given for things not bound here; (c)~with suitably
436 flaggery, that all top-level things have type signatures.
438 At the moment we don't gather free-var info from the types in
439 sigatures. We'd only need this if we wanted to report unused tyvars.
442 renameSigs :: TopLevelFlag
443 -> Bool -- True <-> sigs for an instance decl
444 -- hence SPECIALISE instance prags ok
445 -> NameSet -- Set of names bound in this group
447 -> RnMS s ([RenamedSig], FreeVars) -- List of Sig constructors
449 renameSigs top_lev inst_decl binders sigs
450 = -- Rename the signatures
451 mapAndUnzipRn renameSig sigs `thenRn` \ (sigs', fvs_s) ->
453 -- Check for (a) duplicate signatures
454 -- (b) signatures for things not in this group
455 -- (c) optionally, bindings with no signature
457 (goodies, dups) = removeDups cmp_sig (sigsForMe (not . isUnboundName) sigs')
458 not_this_group = sigsForMe (not . (`elemNameSet` binders)) goodies
459 spec_inst_sigs = [s | s@(SpecInstSig _ _) <- goodies]
460 type_sig_vars = [n | Sig n _ _ <- goodies]
461 fixes = [f | f@(FixSig _) <- goodies]
462 idecl_type_sigs = [s | s@(Sig _ _ _) <- goodies]
463 sigs_required = case top_lev of {TopLevel -> opt_WarnMissingSigs; NotTopLevel -> False}
464 un_sigd_binders | sigs_required = nameSetToList binders `minusList` type_sig_vars
467 mapRn dupSigDeclErr dups `thenRn_`
468 mapRn unknownSigErr not_this_group `thenRn_`
469 (if not inst_decl then
470 mapRn unknownSigErr spec_inst_sigs
472 -- We're being strict here, outlawing the presence
473 -- of type signatures within an instance declaration.
474 mapRn unknownSigErr (fixes ++ idecl_type_sigs)
476 mapRn (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_`
478 returnRn (sigs', plusFVs fvs_s) -- bad ones and all:
479 -- we need bindings of *some* sort for every name
481 -- We use lookupOccRn in the signatures, which is a little bit unsatisfactory
482 -- becuase this won't work for:
483 -- instance Foo T where
486 -- We'll just rename the INLINE prag to refer to whatever other 'op'
487 -- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.)
488 -- Doesn't seem worth much trouble to sort this.
490 renameSig (Sig v ty src_loc)
491 = pushSrcLocRn src_loc $
492 lookupOccRn v `thenRn` \ new_v ->
493 rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) ->
494 returnRn (Sig new_v new_ty src_loc, fvs)
496 renameSig (SpecInstSig ty src_loc)
497 = pushSrcLocRn src_loc $
498 rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ (new_ty, fvs) ->
499 returnRn (SpecInstSig new_ty src_loc, fvs)
501 renameSig (SpecSig v ty using src_loc)
502 = pushSrcLocRn src_loc $
503 lookupOccRn v `thenRn` \ new_v ->
504 rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs1) ->
505 rn_using using `thenRn` \ (new_using,fvs2) ->
506 returnRn (SpecSig new_v new_ty new_using src_loc, fvs1 `plusFV` fvs2)
508 rn_using Nothing = returnRn (Nothing, emptyFVs)
509 rn_using (Just x) = lookupOccRn x `thenRn` \ new_x ->
510 returnRn (Just new_x, unitFV new_x)
512 renameSig (InlineSig v src_loc)
513 = pushSrcLocRn src_loc $
514 lookupOccRn v `thenRn` \ new_v ->
515 returnRn (InlineSig new_v src_loc, emptyFVs)
517 renameSig (FixSig (FixitySig v fix src_loc))
518 = pushSrcLocRn src_loc $
519 lookupOccRn v `thenRn` \ new_v ->
520 returnRn (FixSig (FixitySig new_v fix src_loc), emptyFVs)
522 renameSig (NoInlineSig v src_loc)
523 = pushSrcLocRn src_loc $
524 lookupOccRn v `thenRn` \ new_v ->
525 returnRn (NoInlineSig new_v src_loc, emptyFVs)
528 Checking for distinct signatures; oh, so boring
531 cmp_sig :: RenamedSig -> RenamedSig -> Ordering
532 cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2
533 cmp_sig (InlineSig n1 _) (InlineSig n2 _) = n1 `compare` n2
534 cmp_sig (NoInlineSig n1 _) (NoInlineSig n2 _) = n1 `compare` n2
535 cmp_sig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2
536 cmp_sig (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _)
537 = -- may have many specialisations for one value;
538 -- but not ones that are exactly the same...
539 thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2)
541 cmp_sig other_1 other_2 -- Tags *must* be different
542 | (sig_tag other_1) _LT_ (sig_tag other_2) = LT
545 sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT)
546 sig_tag (SpecSig n1 _ _ _) = ILIT(2)
547 sig_tag (InlineSig n1 _) = ILIT(3)
548 sig_tag (NoInlineSig n1 _) = ILIT(4)
549 sig_tag (SpecInstSig _ _) = ILIT(5)
550 sig_tag (FixSig _) = ILIT(6)
551 sig_tag _ = panic# "tag(RnBinds)"
554 %************************************************************************
556 \subsection{Error messages}
558 %************************************************************************
561 dupSigDeclErr (sig:sigs)
563 addErrRn (sep [ptext SLIT("Duplicate"),
564 ptext what_it_is <> colon,
567 (what_it_is, loc) = sig_doc sig
571 addErrRn (sep [ptext SLIT("Misplaced"),
572 ptext what_it_is <> colon,
575 (what_it_is, loc) = sig_doc sig
577 sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc)
578 sig_doc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc)
579 sig_doc (SpecSig _ _ _ loc) = (SLIT("SPECIALISE pragma"),loc)
580 sig_doc (InlineSig _ loc) = (SLIT("INLINE pragma"),loc)
581 sig_doc (NoInlineSig _ loc) = (SLIT("NOINLINE pragma"),loc)
582 sig_doc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc)
583 sig_doc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc)
586 = sep [ptext SLIT("definition but no type signature for"), quotes (ppr var)]
589 = hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding"))