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,
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 occname inf matches locn)
345 = pushSrcLocRn locn $
346 mapRn (checkPrecMatch inf occname) matches `thenRn_`
348 newLocalNames [(occname, locn)] `thenRn` \ [op_name] ->
349 -- Make a fresh local for the bound variable; it must be different
350 -- to occurrences of the same thing on the LHS, which refer to the global
353 mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) ->
354 returnRn (FunMonoBind op_name inf new_matches locn)
356 rnMethodBinds (PatMonoBind (VarPatIn occname) grhss_and_binds locn)
357 = pushSrcLocRn locn $
358 newLocalNames [(occname, locn)] `thenRn` \ [op_name] ->
359 rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', _) ->
360 returnRn (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn)
362 -- Can't handle method pattern-bindings which bind multiple methods.
363 rnMethodBinds mbind@(PatMonoBind other_pat _ locn)
364 = pushSrcLocRn locn $
365 failWithRn EmptyMonoBinds (methodBindErr mbind)
369 -- If a SPECIALIZE pragma is of the "... = blah" form,
370 -- then we'd better make sure "blah" is taken into
371 -- acct in the dependency analysis (or we get an
372 -- unexpected out-of-scope error)! WDP 95/07
374 sig_fv (SpecSig _ _ (Just blah) _) acc = acc `unionNameSets` (unitNameSet blah)
378 %************************************************************************
380 \subsection[reconstruct-deps]{Reconstructing dependencies}
382 %************************************************************************
384 This @MonoBinds@- and @ClassDecls@-specific code is segregated here,
385 as the two cases are similar.
388 reconstructCycle :: SCC FlatMonoBindsInfo
391 reconstructCycle (AcyclicSCC (_, _, binds, sigs))
392 = MonoBind binds sigs NonRecursive
394 reconstructCycle (CyclicSCC cycle)
395 = MonoBind this_gp_binds this_gp_sigs Recursive
397 this_gp_binds = foldr1 AndMonoBinds [binds | (_, _, binds, _) <- cycle]
398 this_gp_sigs = foldr1 (++) [sigs | (_, _, _, sigs) <- cycle]
401 %************************************************************************
403 %* Manipulating FlatMonoBindInfo *
405 %************************************************************************
407 During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@.
408 The @RenamedMonoBinds@ is always an empty bind, a pattern binding or
409 a function binding, and has itself been dependency-analysed and
413 type FlatMonoBindsInfo
414 = (NameSet, -- Set of names defined in this vertex
415 NameSet, -- Set of names used in this vertex
417 [RenamedSig]) -- Signatures, if any, for this vertex
419 mkEdges :: [(FlatMonoBindsInfo, VertexTag)] -> [(FlatMonoBindsInfo, VertexTag, [VertexTag])]
422 = [ (info, tag, dest_vertices (nameSetToList names_used))
423 | (info@(names_defined, names_used, mbind, sigs), tag) <- flat_info
426 -- An edge (v,v') indicates that v depends on v'
427 dest_vertices src_mentions = [ target_vertex
428 | ((names_defined, _, _, _), target_vertex) <- flat_info,
429 mentioned_name <- src_mentions,
430 mentioned_name `elemNameSet` names_defined
435 %************************************************************************
437 \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
439 %************************************************************************
441 @renameSigs@ checks for: (a)~more than one sig for one thing;
442 (b)~signatures given for things not bound here; (c)~with suitably
443 flaggery, that all top-level things have type signatures.
446 renameSigs :: TopLevelFlag
447 -> Bool -- True <-> sigs for an instance decl
448 -- hence SPECIALISE instance prags ok
449 -> NameSet -- Set of names bound in this group
451 -> RnMS s [RenamedSig] -- List of Sig constructors
453 renameSigs top_lev inst_decl binders sigs
454 = -- Rename the signatures
455 mapRn renameSig sigs `thenRn` \ sigs' ->
457 -- Check for (a) duplicate signatures
458 -- (b) signatures for things not in this group
459 -- (c) optionally, bindings with no signature
461 (goodies, dups) = removeDups cmp_sig (sigsForMe (not . isUnboundName) sigs')
462 not_this_group = sigsForMe (not . (`elemNameSet` binders)) goodies
463 spec_inst_sigs = [s | s@(SpecInstSig _ _) <- goodies]
464 type_sig_vars = [n | Sig n _ _ <- goodies]
465 sigs_required = case top_lev of {TopLevel -> opt_SigsRequired; NotTopLevel -> False}
466 un_sigd_binders | sigs_required = nameSetToList binders `minusList` type_sig_vars
469 mapRn dupSigDeclErr dups `thenRn_`
470 mapRn unknownSigErr not_this_group `thenRn_`
471 (if not inst_decl then
472 mapRn unknownSigErr spec_inst_sigs
476 mapRn (addErrRn.missingSigErr) un_sigd_binders `thenRn_`
478 returnRn sigs' -- bad ones and all:
479 -- we need bindings of *some* sort for every name
482 renameSig (Sig v ty src_loc)
483 = pushSrcLocRn src_loc $
484 lookupBndrRn v `thenRn` \ new_v ->
485 rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty ->
486 returnRn (Sig new_v new_ty src_loc)
488 renameSig (SpecInstSig ty src_loc)
489 = pushSrcLocRn src_loc $
490 rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ new_ty ->
491 returnRn (SpecInstSig new_ty src_loc)
493 renameSig (SpecSig v ty using src_loc)
494 = pushSrcLocRn src_loc $
495 lookupBndrRn v `thenRn` \ new_v ->
496 rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty ->
497 rn_using using `thenRn` \ new_using ->
498 returnRn (SpecSig new_v new_ty new_using src_loc)
500 rn_using Nothing = returnRn Nothing
501 rn_using (Just x) = lookupOccRn x `thenRn` \ new_x ->
502 returnRn (Just new_x)
504 renameSig (InlineSig v src_loc)
505 = pushSrcLocRn src_loc $
506 lookupBndrRn v `thenRn` \ new_v ->
507 returnRn (InlineSig new_v src_loc)
510 Checking for distinct signatures; oh, so boring
513 cmp_sig :: RenamedSig -> RenamedSig -> Ordering
514 cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2
515 cmp_sig (InlineSig n1 _) (InlineSig n2 _) = n1 `compare` n2
516 cmp_sig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2
517 cmp_sig (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _)
518 = -- may have many specialisations for one value;
519 -- but not ones that are exactly the same...
520 thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2)
522 cmp_sig other_1 other_2 -- Tags *must* be different
523 | (sig_tag other_1) _LT_ (sig_tag other_2) = LT
526 sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT)
527 sig_tag (SpecSig n1 _ _ _) = ILIT(2)
528 sig_tag (InlineSig n1 _) = ILIT(3)
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 (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc)
563 = sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)]
566 = hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding"))