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, warnUnusedBinds,
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 warnUnusedBinds 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 ->
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)
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 sig_fv (SpecSig _ _ (Just blah) _) acc = acc `plusFV` unitFV blah
368 %************************************************************************
370 \subsection[reconstruct-deps]{Reconstructing dependencies}
372 %************************************************************************
374 This @MonoBinds@- and @ClassDecls@-specific code is segregated here,
375 as the two cases are similar.
378 reconstructCycle :: SCC FlatMonoBindsInfo
381 reconstructCycle (AcyclicSCC (_, _, binds, sigs))
382 = MonoBind binds sigs NonRecursive
384 reconstructCycle (CyclicSCC cycle)
385 = MonoBind this_gp_binds this_gp_sigs Recursive
387 this_gp_binds = foldr1 AndMonoBinds [binds | (_, _, binds, _) <- cycle]
388 this_gp_sigs = foldr1 (++) [sigs | (_, _, _, sigs) <- cycle]
391 %************************************************************************
393 %* Manipulating FlatMonoBindInfo *
395 %************************************************************************
397 During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@.
398 The @RenamedMonoBinds@ is always an empty bind, a pattern binding or
399 a function binding, and has itself been dependency-analysed and
403 type FlatMonoBindsInfo
404 = (NameSet, -- Set of names defined in this vertex
405 NameSet, -- Set of names used in this vertex
407 [RenamedSig]) -- Signatures, if any, for this vertex
409 mkEdges :: [(FlatMonoBindsInfo, VertexTag)] -> [(FlatMonoBindsInfo, VertexTag, [VertexTag])]
412 = [ (info, tag, dest_vertices (nameSetToList names_used))
413 | (info@(names_defined, names_used, mbind, sigs), tag) <- flat_info
416 -- An edge (v,v') indicates that v depends on v'
417 dest_vertices src_mentions = [ target_vertex
418 | ((names_defined, _, _, _), target_vertex) <- flat_info,
419 mentioned_name <- src_mentions,
420 mentioned_name `elemNameSet` names_defined
425 %************************************************************************
427 \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
429 %************************************************************************
431 @renameSigs@ checks for: (a)~more than one sig for one thing;
432 (b)~signatures given for things not bound here; (c)~with suitably
433 flaggery, that all top-level things have type signatures.
435 At the moment we don't gather free-var info from the types in
436 sigatures. We'd only need this if we wanted to report unused tyvars.
439 renameSigs :: TopLevelFlag
440 -> Bool -- True <-> sigs for an instance decl
441 -- hence SPECIALISE instance prags ok
442 -> NameSet -- Set of names bound in this group
444 -> RnMS s [RenamedSig] -- List of Sig constructors
446 renameSigs top_lev inst_decl binders sigs
447 = -- Rename the signatures
448 mapRn renameSig sigs `thenRn` \ sigs' ->
450 -- Check for (a) duplicate signatures
451 -- (b) signatures for things not in this group
452 -- (c) optionally, bindings with no signature
454 (goodies, dups) = removeDups cmp_sig (sigsForMe (not . isUnboundName) sigs')
455 not_this_group = sigsForMe (not . (`elemNameSet` binders)) goodies
456 spec_inst_sigs = [s | s@(SpecInstSig _ _) <- goodies]
457 type_sig_vars = [n | Sig n _ _ <- goodies]
458 sigs_required = case top_lev of {TopLevel -> opt_WarnMissingSigs; NotTopLevel -> False}
459 un_sigd_binders | sigs_required = nameSetToList binders `minusList` type_sig_vars
462 mapRn dupSigDeclErr dups `thenRn_`
463 mapRn unknownSigErr not_this_group `thenRn_`
464 (if not inst_decl then
465 mapRn unknownSigErr spec_inst_sigs
469 mapRn (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_`
471 returnRn sigs' -- bad ones and all:
472 -- we need bindings of *some* sort for every name
475 renameSig (Sig v ty src_loc)
476 = pushSrcLocRn src_loc $
477 lookupBndrRn v `thenRn` \ new_v ->
478 rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,_) ->
479 returnRn (Sig new_v new_ty src_loc)
481 renameSig (SpecInstSig ty src_loc)
482 = pushSrcLocRn src_loc $
483 rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ (new_ty, _) ->
484 returnRn (SpecInstSig new_ty src_loc)
486 renameSig (SpecSig v ty using src_loc)
487 = pushSrcLocRn src_loc $
488 lookupBndrRn v `thenRn` \ new_v ->
489 rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,_) ->
490 rn_using using `thenRn` \ new_using ->
491 returnRn (SpecSig new_v new_ty new_using src_loc)
493 rn_using Nothing = returnRn Nothing
494 rn_using (Just x) = lookupOccRn x `thenRn` \ new_x ->
495 returnRn (Just new_x)
497 renameSig (InlineSig v src_loc)
498 = pushSrcLocRn src_loc $
499 lookupBndrRn v `thenRn` \ new_v ->
500 returnRn (InlineSig new_v src_loc)
502 renameSig (FixSig (FixitySig v fix src_loc))
503 = pushSrcLocRn src_loc $
504 lookupBndrRn v `thenRn` \ new_v ->
505 returnRn (FixSig (FixitySig new_v fix src_loc))
507 renameSig (NoInlineSig v src_loc)
508 = pushSrcLocRn src_loc $
509 lookupBndrRn v `thenRn` \ new_v ->
510 returnRn (NoInlineSig new_v src_loc)
513 Checking for distinct signatures; oh, so boring
516 cmp_sig :: RenamedSig -> RenamedSig -> Ordering
517 cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2
518 cmp_sig (InlineSig n1 _) (InlineSig n2 _) = n1 `compare` n2
519 cmp_sig (NoInlineSig n1 _) (NoInlineSig n2 _) = n1 `compare` n2
520 cmp_sig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2
521 cmp_sig (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _)
522 = -- may have many specialisations for one value;
523 -- but not ones that are exactly the same...
524 thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2)
526 cmp_sig other_1 other_2 -- Tags *must* be different
527 | (sig_tag other_1) _LT_ (sig_tag other_2) = LT
530 sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT)
531 sig_tag (SpecSig n1 _ _ _) = ILIT(2)
532 sig_tag (InlineSig n1 _) = ILIT(3)
533 sig_tag (NoInlineSig n1 _) = ILIT(4)
534 sig_tag (SpecInstSig _ _) = ILIT(5)
535 sig_tag _ = panic# "tag(RnBinds)"
538 %************************************************************************
540 \subsection{Error messages}
542 %************************************************************************
545 dupSigDeclErr (sig:sigs)
547 addErrRn (sep [ptext SLIT("Duplicate"),
548 ptext what_it_is <> colon,
551 (what_it_is, loc) = sig_doc sig
555 addErrRn (sep [ptext SLIT("Misplaced"),
556 ptext what_it_is <> colon,
559 (what_it_is, loc) = sig_doc sig
561 sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc)
562 sig_doc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc)
563 sig_doc (SpecSig _ _ _ loc) = (SLIT("SPECIALISE pragma"),loc)
564 sig_doc (InlineSig _ loc) = (SLIT("INLINE pragma"),loc)
565 sig_doc (NoInlineSig _ loc) = (SLIT("NOINLINE pragma"),loc)
566 sig_doc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc)
569 = sep [ptext SLIT("definition but no type signature for"), quotes (ppr var)]
572 = hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding"))