2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
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 newLocalNames, isUnboundName, warnUnusedBinds
31 import CmdLineOpts ( opt_SigsRequired )
32 import Digraph ( stronglyConnComp, SCC(..) )
33 import Name ( OccName(..), Provenance,
35 NameSet, emptyNameSet, mkNameSet, unionNameSets,
36 minusNameSet, unionManyNameSets, elemNameSet, unitNameSet, nameSetToList
38 import BasicTypes ( RecFlag(..), TopLevelFlag(..) )
39 import Util ( thenCmp, removeDups, panic, panic#, assertPanic )
40 import UniqSet ( UniqSet )
41 import ListSetOps ( minusList )
42 import Bag ( bagToList )
43 import UniqFM ( UniqFM )
47 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
48 -- place and can be used when complaining.
50 The code tree received by the function @rnBinds@ contains definitions
51 in where-clauses which are all apparently mutually recursive, but which may
52 not really depend upon each other. For example, in the top level program
57 the definitions of @a@ and @y@ do not depend on each other at all.
58 Unfortunately, the typechecker cannot always check such definitions.
59 \footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
60 definitions. In Proceedings of the International Symposium on Programming,
61 Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
62 However, the typechecker usually can check definitions in which only the
63 strongly connected components have been collected into recursive bindings.
64 This is precisely what the function @rnBinds@ does.
66 ToDo: deal with case where a single monobinds binds the same variable
69 The vertag tag is a unique @Int@; the tags only need to be unique
70 within one @MonoBinds@, so that unique-Int plumbing is done explicitly
71 (heavy monad machinery not needed).
75 type Cycle = [VertexTag]
76 type Edge = (VertexTag, VertexTag)
79 %************************************************************************
81 %* naming conventions *
83 %************************************************************************
85 \subsection[name-conventions]{Name conventions}
87 The basic algorithm involves walking over the tree and returning a tuple
88 containing the new tree plus its free variables. Some functions, such
89 as those walking polymorphic bindings (HsBinds) and qualifier lists in
90 list comprehensions (@Quals@), return the variables bound in local
91 environments. These are then used to calculate the free variables of the
92 expression evaluated in these environments.
94 Conventions for variable names are as follows:
97 new code is given a prime to distinguish it from the old.
100 a set of variables defined in @Exp@ is written @dvExp@
103 a set of variables free in @Exp@ is written @fvExp@
106 %************************************************************************
108 %* analysing polymorphic bindings (HsBinds, Bind, MonoBinds) *
110 %************************************************************************
112 \subsubsection[dep-HsBinds]{Polymorphic bindings}
114 Non-recursive expressions are reconstructed without any changes at top
115 level, although their component expressions may have to be altered.
116 However, non-recursive expressions are currently not expected as
117 \Haskell{} programs, and this code should not be executed.
119 Monomorphic bindings contain information that is returned in a tuple
120 (a @FlatMonoBindsInfo@) containing:
124 a unique @Int@ that serves as the ``vertex tag'' for this binding.
127 the name of a function or the names in a pattern. These are a set
128 referred to as @dvLhs@, the defined variables of the left hand side.
131 the free variables of the body. These are referred to as @fvBody@.
134 the definition's actual code. This is referred to as just @code@.
137 The function @nonRecDvFv@ returns two sets of variables. The first is
138 the set of variables defined in the set of monomorphic bindings, while the
139 second is the set of free variables in those bindings.
141 The set of variables defined in a non-recursive binding is just the
142 union of all of them, as @union@ removes duplicates. However, the
143 free variables in each successive set of cumulative bindings is the
144 union of those in the previous set plus those of the newest binding after
145 the defined variables of the previous set have been removed.
147 @rnMethodBinds@ deals only with the declarations in class and
148 instance declarations. It expects only to see @FunMonoBind@s, and
149 it expects the global environment to contain bindings for the binders
150 (which are all class operations).
152 %************************************************************************
154 %* Top-level bindings
156 %************************************************************************
158 @rnTopBinds@ assumes that the environment already
159 contains bindings for the binders of this particular binding.
162 rnTopBinds :: RdrNameHsBinds -> RnMS s RenamedHsBinds
164 rnTopBinds EmptyBinds = returnRn EmptyBinds
165 rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs
166 -- The parser doesn't produce other forms
169 rnTopMonoBinds EmptyMonoBinds sigs
170 = returnRn EmptyBinds
172 rnTopMonoBinds mbinds sigs
173 = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names ->
175 binder_set = mkNameSet binder_names
176 exported_binders = mkNameSet (filter isExportedName binder_names)
178 rn_mono_binds TopLevel
179 binder_set mbinds sigs `thenRn` \ (new_binds, fv_set) ->
181 unused_binders = binder_set `minusNameSet` (fv_set `unionNameSets` exported_binders)
183 warnUnusedBinds unused_binders `thenRn_`
186 binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds))
189 %************************************************************************
193 %************************************************************************
196 - collects up the binders for this declaration group,
197 - checks that they form a set
198 - extends the environment to bind them to new local names
199 - calls @rnMonoBinds@ to do the real work
202 rnBinds :: RdrNameHsBinds
203 -> (RenamedHsBinds -> RnMS s (result, FreeVars))
204 -> RnMS s (result, FreeVars)
206 rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds
207 rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside
208 -- the parser doesn't produce other forms
211 rnMonoBinds :: RdrNameMonoBinds -> [RdrNameSig]
212 -> (RenamedHsBinds -> RnMS s (result, FreeVars))
213 -> RnMS s (result, FreeVars)
215 rnMonoBinds EmptyMonoBinds sigs thing_inside = thing_inside EmptyBinds
217 rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds
218 = -- Extract all the binders in this group,
219 -- and extend current scope, inventing new names for the new binders
220 -- This also checks that the names form a set
221 bindLocatedLocalsRn (text "binding group") mbinders_w_srclocs $ \ new_mbinders ->
223 binder_set = mkNameSet new_mbinders
225 rn_mono_binds NotTopLevel
226 binder_set mbinds sigs `thenRn` \ (binds,bind_fvs) ->
228 -- Now do the "thing inside", and deal with the free-variable calculations
229 thing_inside binds `thenRn` \ (result,result_fvs) ->
231 all_fvs = result_fvs `unionNameSets` bind_fvs
232 net_fvs = all_fvs `minusNameSet` binder_set
233 unused_binders = binder_set `minusNameSet` all_fvs
235 warnUnusedBinds unused_binders `thenRn_`
236 returnRn (result, net_fvs)
238 mbinders_w_srclocs = bagToList (collectMonoBinders mbinds)
242 %************************************************************************
244 %* MonoBinds -- the main work is done here
246 %************************************************************************
248 @rnMonoBinds@ is used by *both* top-level and nested bindings. It
249 assumes that all variables bound in this group are already in scope.
250 This is done *either* by pass 3 (for the top-level bindings), *or* by
251 @rnNestedMonoBinds@ (for the nested ones).
254 rn_mono_binds :: TopLevelFlag
255 -> NameSet -- Binders of this group
257 -> [RdrNameSig] -- Signatures attached to this group
258 -> RnMS s (RenamedHsBinds, --
259 FreeVars) -- Free variables
261 rn_mono_binds top_lev binders mbinds sigs
263 -- Rename the bindings, returning a MonoBindsInfo
264 -- which is a list of indivisible vertices so far as
265 -- the strongly-connected-components (SCC) analysis is concerned
266 renameSigs top_lev False binders sigs `thenRn` \ siglist ->
267 flattenMonoBinds siglist mbinds `thenRn` \ mbinds_info ->
269 -- Do the SCC analysis
270 let edges = mkEdges (mbinds_info `zip` [(0::Int)..])
271 scc_result = stronglyConnComp edges
272 final_binds = foldr1 ThenBinds (map reconstructCycle scc_result)
274 -- Deal with bound and free-var calculation
275 rhs_fvs = unionManyNameSets [fvs | (_,fvs,_,_) <- mbinds_info]
277 returnRn (final_binds, rhs_fvs)
280 @flattenMonoBinds@ is ever-so-slightly magical in that it sticks
281 unique ``vertex tags'' on its output; minor plumbing required.
284 flattenMonoBinds :: [RenamedSig] -- Signatures
286 -> RnMS s [FlatMonoBindsInfo]
288 flattenMonoBinds sigs EmptyMonoBinds = returnRn []
290 flattenMonoBinds sigs (AndMonoBinds bs1 bs2)
291 = flattenMonoBinds sigs bs1 `thenRn` \ flat1 ->
292 flattenMonoBinds sigs bs2 `thenRn` \ flat2 ->
293 returnRn (flat1 ++ flat2)
295 flattenMonoBinds sigs (PatMonoBind pat grhss_and_binds locn)
296 = pushSrcLocRn locn $
297 rnPat pat `thenRn` \ pat' ->
298 rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
300 -- Find which things are bound in this group
302 names_bound_here = mkNameSet (collectPatBinders pat')
303 sigs_for_me = sigsForMe (`elemNameSet` names_bound_here) sigs
304 sigs_fvs = foldr sig_fv emptyNameSet sigs_for_me
308 fvs `unionNameSets` sigs_fvs,
309 PatMonoBind pat' grhss_and_binds' locn,
313 flattenMonoBinds sigs (FunMonoBind name inf matches locn)
314 = pushSrcLocRn locn $
315 mapRn (checkPrecMatch inf name) matches `thenRn_`
316 lookupBndrRn name `thenRn` \ name' ->
317 mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) ->
319 fvs = unionManyNameSets fv_lists
320 sigs_for_me = sigsForMe (name' ==) sigs
321 sigs_fvs = foldr sig_fv emptyNameSet sigs_for_me
325 fvs `unionNameSets` sigs_fvs,
326 FunMonoBind name' inf new_matches locn,
332 @rnMethodBinds@ is used for the method bindings of an instance
333 declaration. like @rnMonoBinds@ but without dependency analysis.
336 rnMethodBinds :: RdrNameMonoBinds -> RnMS s RenamedMonoBinds
338 rnMethodBinds EmptyMonoBinds = returnRn EmptyMonoBinds
340 rnMethodBinds (AndMonoBinds mb1 mb2)
341 = andRn AndMonoBinds (rnMethodBinds mb1)
344 rnMethodBinds (FunMonoBind name inf matches locn)
345 = pushSrcLocRn locn $
346 mapRn (checkPrecMatch inf name) matches `thenRn_`
348 lookupGlobalOccRn name `thenRn` \ sel_name ->
349 -- We use the selector name as the binder
351 mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) ->
352 returnRn (FunMonoBind sel_name inf new_matches locn)
354 rnMethodBinds (PatMonoBind (VarPatIn name) grhss_and_binds locn)
355 = pushSrcLocRn locn $
356 lookupGlobalOccRn name `thenRn` \ sel_name ->
357 rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', _) ->
358 returnRn (PatMonoBind (VarPatIn sel_name) grhss_and_binds' locn)
360 -- Can't handle method pattern-bindings which bind multiple methods.
361 rnMethodBinds mbind@(PatMonoBind other_pat _ locn)
362 = pushSrcLocRn locn $
363 failWithRn EmptyMonoBinds (methodBindErr mbind)
367 -- If a SPECIALIZE pragma is of the "... = blah" form,
368 -- then we'd better make sure "blah" is taken into
369 -- acct in the dependency analysis (or we get an
370 -- unexpected out-of-scope error)! WDP 95/07
372 sig_fv (SpecSig _ _ (Just blah) _) acc = acc `unionNameSets` (unitNameSet blah)
376 %************************************************************************
378 \subsection[reconstruct-deps]{Reconstructing dependencies}
380 %************************************************************************
382 This @MonoBinds@- and @ClassDecls@-specific code is segregated here,
383 as the two cases are similar.
386 reconstructCycle :: SCC FlatMonoBindsInfo
389 reconstructCycle (AcyclicSCC (_, _, binds, sigs))
390 = MonoBind binds sigs NonRecursive
392 reconstructCycle (CyclicSCC cycle)
393 = MonoBind this_gp_binds this_gp_sigs Recursive
395 this_gp_binds = foldr1 AndMonoBinds [binds | (_, _, binds, _) <- cycle]
396 this_gp_sigs = foldr1 (++) [sigs | (_, _, _, sigs) <- cycle]
399 %************************************************************************
401 %* Manipulating FlatMonoBindInfo *
403 %************************************************************************
405 During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@.
406 The @RenamedMonoBinds@ is always an empty bind, a pattern binding or
407 a function binding, and has itself been dependency-analysed and
411 type FlatMonoBindsInfo
412 = (NameSet, -- Set of names defined in this vertex
413 NameSet, -- Set of names used in this vertex
415 [RenamedSig]) -- Signatures, if any, for this vertex
417 mkEdges :: [(FlatMonoBindsInfo, VertexTag)] -> [(FlatMonoBindsInfo, VertexTag, [VertexTag])]
420 = [ (info, tag, dest_vertices (nameSetToList names_used))
421 | (info@(names_defined, names_used, mbind, sigs), tag) <- flat_info
424 -- An edge (v,v') indicates that v depends on v'
425 dest_vertices src_mentions = [ target_vertex
426 | ((names_defined, _, _, _), target_vertex) <- flat_info,
427 mentioned_name <- src_mentions,
428 mentioned_name `elemNameSet` names_defined
433 %************************************************************************
435 \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
437 %************************************************************************
439 @renameSigs@ checks for: (a)~more than one sig for one thing;
440 (b)~signatures given for things not bound here; (c)~with suitably
441 flaggery, that all top-level things have type signatures.
444 renameSigs :: TopLevelFlag
445 -> Bool -- True <-> sigs for an instance decl
446 -- hence SPECIALISE instance prags ok
447 -> NameSet -- Set of names bound in this group
449 -> RnMS s [RenamedSig] -- List of Sig constructors
451 renameSigs top_lev inst_decl binders sigs
452 = -- Rename the signatures
453 mapRn renameSig sigs `thenRn` \ sigs' ->
455 -- Check for (a) duplicate signatures
456 -- (b) signatures for things not in this group
457 -- (c) optionally, bindings with no signature
459 (goodies, dups) = removeDups cmp_sig (sigsForMe (not . isUnboundName) sigs')
460 not_this_group = sigsForMe (not . (`elemNameSet` binders)) goodies
461 spec_inst_sigs = [s | s@(SpecInstSig _ _) <- goodies]
462 type_sig_vars = [n | Sig n _ _ <- goodies]
463 sigs_required = case top_lev of {TopLevel -> opt_SigsRequired; 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
474 mapRn (addErrRn.missingSigErr) un_sigd_binders `thenRn_`
476 returnRn sigs' -- bad ones and all:
477 -- we need bindings of *some* sort for every name
480 renameSig (Sig v ty src_loc)
481 = pushSrcLocRn src_loc $
482 lookupBndrRn v `thenRn` \ new_v ->
483 rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty ->
484 returnRn (Sig new_v new_ty src_loc)
486 renameSig (SpecInstSig ty src_loc)
487 = pushSrcLocRn src_loc $
488 rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ new_ty ->
489 returnRn (SpecInstSig new_ty src_loc)
491 renameSig (SpecSig v ty using src_loc)
492 = pushSrcLocRn src_loc $
493 lookupBndrRn v `thenRn` \ new_v ->
494 rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty ->
495 rn_using using `thenRn` \ new_using ->
496 returnRn (SpecSig new_v new_ty new_using src_loc)
498 rn_using Nothing = returnRn Nothing
499 rn_using (Just x) = lookupOccRn x `thenRn` \ new_x ->
500 returnRn (Just new_x)
502 renameSig (InlineSig v src_loc)
503 = pushSrcLocRn src_loc $
504 lookupBndrRn v `thenRn` \ new_v ->
505 returnRn (InlineSig new_v 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"))