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, rnGRHSsAndBinds, rnPat, checkPrecMatch )
28 import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, lookupGlobalOccRn,
29 isUnboundName, warnUnusedBinds
31 import CmdLineOpts ( opt_WarnMissingSigs )
32 import Digraph ( stronglyConnComp, SCC(..) )
33 import Name ( OccName(..), Name, isExportedName )
35 import BasicTypes ( RecFlag(..), TopLevelFlag(..) )
36 import Util ( thenCmp, removeDups, panic, panic#, assertPanic )
37 import ListSetOps ( minusList )
38 import Bag ( bagToList )
42 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
43 -- place and can be used when complaining.
45 The code tree received by the function @rnBinds@ contains definitions
46 in where-clauses which are all apparently mutually recursive, but which may
47 not really depend upon each other. For example, in the top level program
52 the definitions of @a@ and @y@ do not depend on each other at all.
53 Unfortunately, the typechecker cannot always check such definitions.
54 \footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
55 definitions. In Proceedings of the International Symposium on Programming,
56 Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
57 However, the typechecker usually can check definitions in which only the
58 strongly connected components have been collected into recursive bindings.
59 This is precisely what the function @rnBinds@ does.
61 ToDo: deal with case where a single monobinds binds the same variable
64 The vertag tag is a unique @Int@; the tags only need to be unique
65 within one @MonoBinds@, so that unique-Int plumbing is done explicitly
66 (heavy monad machinery not needed).
70 type Cycle = [VertexTag]
71 type Edge = (VertexTag, VertexTag)
74 %************************************************************************
76 %* naming conventions *
78 %************************************************************************
80 \subsection[name-conventions]{Name conventions}
82 The basic algorithm involves walking over the tree and returning a tuple
83 containing the new tree plus its free variables. Some functions, such
84 as those walking polymorphic bindings (HsBinds) and qualifier lists in
85 list comprehensions (@Quals@), return the variables bound in local
86 environments. These are then used to calculate the free variables of the
87 expression evaluated in these environments.
89 Conventions for variable names are as follows:
92 new code is given a prime to distinguish it from the old.
95 a set of variables defined in @Exp@ is written @dvExp@
98 a set of variables free in @Exp@ is written @fvExp@
101 %************************************************************************
103 %* analysing polymorphic bindings (HsBinds, Bind, MonoBinds) *
105 %************************************************************************
107 \subsubsection[dep-HsBinds]{Polymorphic bindings}
109 Non-recursive expressions are reconstructed without any changes at top
110 level, although their component expressions may have to be altered.
111 However, non-recursive expressions are currently not expected as
112 \Haskell{} programs, and this code should not be executed.
114 Monomorphic bindings contain information that is returned in a tuple
115 (a @FlatMonoBindsInfo@) containing:
119 a unique @Int@ that serves as the ``vertex tag'' for this binding.
122 the name of a function or the names in a pattern. These are a set
123 referred to as @dvLhs@, the defined variables of the left hand side.
126 the free variables of the body. These are referred to as @fvBody@.
129 the definition's actual code. This is referred to as just @code@.
132 The function @nonRecDvFv@ returns two sets of variables. The first is
133 the set of variables defined in the set of monomorphic bindings, while the
134 second is the set of free variables in those bindings.
136 The set of variables defined in a non-recursive binding is just the
137 union of all of them, as @union@ removes duplicates. However, the
138 free variables in each successive set of cumulative bindings is the
139 union of those in the previous set plus those of the newest binding after
140 the defined variables of the previous set have been removed.
142 @rnMethodBinds@ deals only with the declarations in class and
143 instance declarations. It expects only to see @FunMonoBind@s, and
144 it expects the global environment to contain bindings for the binders
145 (which are all class operations).
147 %************************************************************************
149 %* Top-level bindings
151 %************************************************************************
153 @rnTopBinds@ assumes that the environment already
154 contains bindings for the binders of this particular binding.
157 rnTopBinds :: RdrNameHsBinds -> RnMS s RenamedHsBinds
159 rnTopBinds EmptyBinds = returnRn EmptyBinds
160 rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs
161 -- The parser doesn't produce other forms
164 rnTopMonoBinds EmptyMonoBinds sigs
165 = returnRn EmptyBinds
167 rnTopMonoBinds mbinds sigs
168 = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names ->
170 binder_set = mkNameSet binder_names
171 exported_binders = mkNameSet (filter isExportedName binder_names)
173 rn_mono_binds TopLevel
174 binder_set mbinds sigs `thenRn` \ (new_binds, fv_set) ->
176 unused_binders = binder_set `minusNameSet` (fv_set `unionNameSets` exported_binders)
178 warnUnusedBinds unused_binders `thenRn_`
181 binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds))
184 %************************************************************************
188 %************************************************************************
191 - collects up the binders for this declaration group,
192 - checks that they form a set
193 - extends the environment to bind them to new local names
194 - calls @rnMonoBinds@ to do the real work
197 rnBinds :: RdrNameHsBinds
198 -> (RenamedHsBinds -> RnMS s (result, FreeVars))
199 -> RnMS s (result, FreeVars)
201 rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds
202 rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside
203 -- the parser doesn't produce other forms
206 rnMonoBinds :: RdrNameMonoBinds -> [RdrNameSig]
207 -> (RenamedHsBinds -> RnMS s (result, FreeVars))
208 -> RnMS s (result, FreeVars)
210 rnMonoBinds EmptyMonoBinds sigs thing_inside = thing_inside EmptyBinds
212 rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds
213 = -- Extract all the binders in this group,
214 -- and extend current scope, inventing new names for the new binders
215 -- This also checks that the names form a set
216 bindLocatedLocalsRn (text "binding group") mbinders_w_srclocs $ \ new_mbinders ->
218 binder_set = mkNameSet new_mbinders
220 rn_mono_binds NotTopLevel
221 binder_set mbinds sigs `thenRn` \ (binds,bind_fvs) ->
223 -- Now do the "thing inside", and deal with the free-variable calculations
224 thing_inside binds `thenRn` \ (result,result_fvs) ->
226 all_fvs = result_fvs `unionNameSets` bind_fvs
227 net_fvs = all_fvs `minusNameSet` binder_set
228 unused_binders = binder_set `minusNameSet` all_fvs
230 warnUnusedBinds unused_binders `thenRn_`
231 returnRn (result, net_fvs)
233 mbinders_w_srclocs = bagToList (collectMonoBinders mbinds)
237 %************************************************************************
239 %* MonoBinds -- the main work is done here
241 %************************************************************************
243 @rnMonoBinds@ is used by *both* top-level and nested bindings. It
244 assumes that all variables bound in this group are already in scope.
245 This is done *either* by pass 3 (for the top-level bindings), *or* by
246 @rnNestedMonoBinds@ (for the nested ones).
249 rn_mono_binds :: TopLevelFlag
250 -> NameSet -- Binders of this group
252 -> [RdrNameSig] -- Signatures attached to this group
253 -> RnMS s (RenamedHsBinds, --
254 FreeVars) -- Free variables
256 rn_mono_binds top_lev binders mbinds sigs
258 -- Rename the bindings, returning a MonoBindsInfo
259 -- which is a list of indivisible vertices so far as
260 -- the strongly-connected-components (SCC) analysis is concerned
261 renameSigs top_lev False binders sigs `thenRn` \ siglist ->
262 flattenMonoBinds siglist mbinds `thenRn` \ mbinds_info ->
264 -- Do the SCC analysis
265 let edges = mkEdges (mbinds_info `zip` [(0::Int)..])
266 scc_result = stronglyConnComp edges
267 final_binds = foldr1 ThenBinds (map reconstructCycle scc_result)
269 -- Deal with bound and free-var calculation
270 rhs_fvs = unionManyNameSets [fvs | (_,fvs,_,_) <- mbinds_info]
272 returnRn (final_binds, rhs_fvs)
275 @flattenMonoBinds@ is ever-so-slightly magical in that it sticks
276 unique ``vertex tags'' on its output; minor plumbing required.
279 flattenMonoBinds :: [RenamedSig] -- Signatures
281 -> RnMS s [FlatMonoBindsInfo]
283 flattenMonoBinds sigs EmptyMonoBinds = returnRn []
285 flattenMonoBinds sigs (AndMonoBinds bs1 bs2)
286 = flattenMonoBinds sigs bs1 `thenRn` \ flat1 ->
287 flattenMonoBinds sigs bs2 `thenRn` \ flat2 ->
288 returnRn (flat1 ++ flat2)
290 flattenMonoBinds sigs (PatMonoBind pat grhss_and_binds locn)
291 = pushSrcLocRn locn $
292 rnPat pat `thenRn` \ pat' ->
293 rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
295 -- Find which things are bound in this group
297 names_bound_here = mkNameSet (collectPatBinders pat')
298 sigs_for_me = sigsForMe (`elemNameSet` names_bound_here) sigs
299 sigs_fvs = foldr sig_fv emptyNameSet sigs_for_me
303 fvs `unionNameSets` sigs_fvs,
304 PatMonoBind pat' grhss_and_binds' locn,
308 flattenMonoBinds sigs (FunMonoBind name inf matches locn)
309 = pushSrcLocRn locn $
310 mapRn (checkPrecMatch inf name) matches `thenRn_`
311 lookupBndrRn name `thenRn` \ name' ->
312 mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) ->
314 fvs = unionManyNameSets fv_lists
315 sigs_for_me = sigsForMe (name' ==) sigs
316 sigs_fvs = foldr sig_fv emptyNameSet sigs_for_me
320 fvs `unionNameSets` sigs_fvs,
321 FunMonoBind name' inf new_matches locn,
327 @rnMethodBinds@ is used for the method bindings of an instance
328 declaration. like @rnMonoBinds@ but without dependency analysis.
331 rnMethodBinds :: RdrNameMonoBinds -> RnMS s RenamedMonoBinds
333 rnMethodBinds EmptyMonoBinds = returnRn EmptyMonoBinds
335 rnMethodBinds (AndMonoBinds mb1 mb2)
336 = andRn AndMonoBinds (rnMethodBinds mb1)
339 rnMethodBinds (FunMonoBind name inf matches locn)
340 = pushSrcLocRn locn $
341 mapRn (checkPrecMatch inf name) matches `thenRn_`
343 lookupGlobalOccRn name `thenRn` \ sel_name ->
344 -- We use the selector name as the binder
346 mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) ->
347 returnRn (FunMonoBind sel_name inf new_matches locn)
349 rnMethodBinds (PatMonoBind (VarPatIn name) grhss_and_binds locn)
350 = pushSrcLocRn locn $
351 lookupGlobalOccRn name `thenRn` \ sel_name ->
352 rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', _) ->
353 returnRn (PatMonoBind (VarPatIn sel_name) grhss_and_binds' locn)
355 -- Can't handle method pattern-bindings which bind multiple methods.
356 rnMethodBinds mbind@(PatMonoBind other_pat _ locn)
357 = pushSrcLocRn locn $
358 failWithRn EmptyMonoBinds (methodBindErr mbind)
362 -- If a SPECIALIZE pragma is of the "... = blah" form,
363 -- then we'd better make sure "blah" is taken into
364 -- acct in the dependency analysis (or we get an
365 -- unexpected out-of-scope error)! WDP 95/07
367 sig_fv (SpecSig _ _ (Just blah) _) acc = acc `unionNameSets` (unitNameSet 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.
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 (NoInlineSig v src_loc)
503 = pushSrcLocRn src_loc $
504 lookupBndrRn v `thenRn` \ new_v ->
505 returnRn (NoInlineSig new_v src_loc)
508 Checking for distinct signatures; oh, so boring
511 cmp_sig :: RenamedSig -> RenamedSig -> Ordering
512 cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2
513 cmp_sig (InlineSig n1 _) (InlineSig n2 _) = n1 `compare` n2
514 cmp_sig (NoInlineSig n1 _) (NoInlineSig n2 _) = n1 `compare` n2
515 cmp_sig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2
516 cmp_sig (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _)
517 = -- may have many specialisations for one value;
518 -- but not ones that are exactly the same...
519 thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2)
521 cmp_sig other_1 other_2 -- Tags *must* be different
522 | (sig_tag other_1) _LT_ (sig_tag other_2) = LT
525 sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT)
526 sig_tag (SpecSig n1 _ _ _) = ILIT(2)
527 sig_tag (InlineSig n1 _) = ILIT(3)
528 sig_tag (NoInlineSig n1 _) = ILIT(4)
529 sig_tag (SpecInstSig _ _) = ILIT(5)
530 sig_tag _ = panic# "tag(RnBinds)"
533 %************************************************************************
535 \subsection{Error messages}
537 %************************************************************************
540 dupSigDeclErr (sig:sigs)
542 addErrRn (sep [ptext SLIT("Duplicate"),
543 ptext what_it_is <> colon,
546 (what_it_is, loc) = sig_doc sig
550 addErrRn (sep [ptext SLIT("Misplaced"),
551 ptext what_it_is <> colon,
554 (what_it_is, loc) = sig_doc sig
556 sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc)
557 sig_doc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc)
558 sig_doc (SpecSig _ _ _ loc) = (SLIT("SPECIALISE pragma"),loc)
559 sig_doc (InlineSig _ loc) = (SLIT("INLINE pragma"),loc)
560 sig_doc (NoInlineSig _ loc) = (SLIT("NOINLINE pragma"),loc)
561 sig_doc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc)
564 = sep [ptext SLIT("definition but no type signature for"), quotes (ppr var)]
567 = hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding"))