[project @ 1998-02-10 14:15:51 by simonpj]
[ghc-hetmet.git] / ghc / compiler / rename / RnBinds.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
3 %
4 \section[RnBinds]{Renaming and dependency analysis of bindings}
5
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).
10
11 \begin{code}
12 module RnBinds (
13         rnTopBinds, rnTopMonoBinds,
14         rnMethodBinds,
15         rnBinds, rnMonoBinds
16    ) where
17
18 #include "HsVersions.h"
19
20 import {-# SOURCE #-} RnSource ( rnHsSigType )
21
22 import HsSyn
23 import RdrHsSyn
24 import RnHsSyn
25 import RnMonad
26 import RnExpr           ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch )
27 import RnEnv            ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, 
28                           newLocalNames, isUnboundName, warnUnusedBinds
29                         )
30 import CmdLineOpts      ( opt_SigsRequired )
31 import Digraph          ( stronglyConnComp, SCC(..) )
32 import Name             ( OccName(..), Provenance, 
33                           Name, isExportedName,
34                           NameSet(..), emptyNameSet, mkNameSet, unionNameSets, 
35                           minusNameSet, unionManyNameSets, elemNameSet, unitNameSet, nameSetToList
36                         )
37 import BasicTypes       ( RecFlag(..), TopLevelFlag(..) )
38 import Util             ( thenCmp, removeDups, panic, panic#, assertPanic )
39 import UniqSet          ( UniqSet )
40 import ListSetOps       ( minusList )
41 import Bag              ( bagToList )
42 import UniqFM           ( UniqFM )
43 import Outputable
44 \end{code}
45
46 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
47 -- place and can be used when complaining.
48
49 The code tree received by the function @rnBinds@ contains definitions
50 in where-clauses which are all apparently mutually recursive, but which may
51 not really depend upon each other. For example, in the top level program
52 \begin{verbatim}
53 f x = y where a = x
54               y = x
55 \end{verbatim}
56 the definitions of @a@ and @y@ do not depend on each other at all.
57 Unfortunately, the typechecker cannot always check such definitions.
58 \footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
59 definitions. In Proceedings of the International Symposium on Programming,
60 Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
61 However, the typechecker usually can check definitions in which only the
62 strongly connected components have been collected into recursive bindings.
63 This is precisely what the function @rnBinds@ does.
64
65 ToDo: deal with case where a single monobinds binds the same variable
66 twice.
67
68 The vertag tag is a unique @Int@; the tags only need to be unique
69 within one @MonoBinds@, so that unique-Int plumbing is done explicitly
70 (heavy monad machinery not needed).
71
72 \begin{code}
73 type VertexTag  = Int
74 type Cycle      = [VertexTag]
75 type Edge       = (VertexTag, VertexTag)
76 \end{code}
77
78 %************************************************************************
79 %*                                                                      *
80 %* naming conventions                                                   *
81 %*                                                                      *
82 %************************************************************************
83
84 \subsection[name-conventions]{Name conventions}
85
86 The basic algorithm involves walking over the tree and returning a tuple
87 containing the new tree plus its free variables. Some functions, such
88 as those walking polymorphic bindings (HsBinds) and qualifier lists in
89 list comprehensions (@Quals@), return the variables bound in local
90 environments. These are then used to calculate the free variables of the
91 expression evaluated in these environments.
92
93 Conventions for variable names are as follows:
94 \begin{itemize}
95 \item
96 new code is given a prime to distinguish it from the old.
97
98 \item
99 a set of variables defined in @Exp@ is written @dvExp@
100
101 \item
102 a set of variables free in @Exp@ is written @fvExp@
103 \end{itemize}
104
105 %************************************************************************
106 %*                                                                      *
107 %* analysing polymorphic bindings (HsBinds, Bind, MonoBinds)            *
108 %*                                                                      *
109 %************************************************************************
110
111 \subsubsection[dep-HsBinds]{Polymorphic bindings}
112
113 Non-recursive expressions are reconstructed without any changes at top
114 level, although their component expressions may have to be altered.
115 However, non-recursive expressions are currently not expected as
116 \Haskell{} programs, and this code should not be executed.
117
118 Monomorphic bindings contain information that is returned in a tuple
119 (a @FlatMonoBindsInfo@) containing:
120
121 \begin{enumerate}
122 \item
123 a unique @Int@ that serves as the ``vertex tag'' for this binding.
124
125 \item
126 the name of a function or the names in a pattern. These are a set
127 referred to as @dvLhs@, the defined variables of the left hand side.
128
129 \item
130 the free variables of the body. These are referred to as @fvBody@.
131
132 \item
133 the definition's actual code. This is referred to as just @code@.
134 \end{enumerate}
135
136 The function @nonRecDvFv@ returns two sets of variables. The first is
137 the set of variables defined in the set of monomorphic bindings, while the
138 second is the set of free variables in those bindings.
139
140 The set of variables defined in a non-recursive binding is just the
141 union of all of them, as @union@ removes duplicates. However, the
142 free variables in each successive set of cumulative bindings is the
143 union of those in the previous set plus those of the newest binding after
144 the defined variables of the previous set have been removed.
145
146 @rnMethodBinds@ deals only with the declarations in class and
147 instance declarations.  It expects only to see @FunMonoBind@s, and
148 it expects the global environment to contain bindings for the binders
149 (which are all class operations).
150
151 %************************************************************************
152 %*                                                                      *
153 %*              Top-level bindings
154 %*                                                                      *
155 %************************************************************************
156
157 @rnTopBinds@ assumes that the environment already
158 contains bindings for the binders of this particular binding.
159
160 \begin{code}
161 rnTopBinds    :: RdrNameHsBinds -> RnMS s RenamedHsBinds
162
163 rnTopBinds EmptyBinds                     = returnRn EmptyBinds
164 rnTopBinds (MonoBind bind sigs _)         = rnTopMonoBinds bind sigs
165   -- The parser doesn't produce other forms
166
167
168 rnTopMonoBinds EmptyMonoBinds sigs 
169   = returnRn EmptyBinds
170
171 rnTopMonoBinds mbinds sigs
172  =  mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names ->
173     let
174         binder_set       = mkNameSet binder_names
175         exported_binders = mkNameSet (filter isExportedName binder_names)
176     in
177     rn_mono_binds TopLevel
178                   binder_set mbinds sigs                `thenRn` \ (new_binds, fv_set) ->
179     let
180         unused_binders = binder_set `minusNameSet` (fv_set `unionNameSets` exported_binders)
181     in
182     warnUnusedBinds unused_binders      `thenRn_`
183     returnRn new_binds
184   where
185     binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds))
186 \end{code}
187
188 %************************************************************************
189 %*                                                                      *
190 %*              Nested binds
191 %*                                                                      *
192 %************************************************************************
193
194 @rnMonoBinds@
195         - collects up the binders for this declaration group,
196         - checks that they form a set
197         - extends the environment to bind them to new local names
198         - calls @rnMonoBinds@ to do the real work
199
200 \begin{code}
201 rnBinds       :: RdrNameHsBinds 
202               -> (RenamedHsBinds -> RnMS s (result, FreeVars))
203               -> RnMS s (result, FreeVars)
204
205 rnBinds EmptyBinds             thing_inside = thing_inside EmptyBinds
206 rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside
207   -- the parser doesn't produce other forms
208
209
210 rnMonoBinds :: RdrNameMonoBinds -> [RdrNameSig]
211             -> (RenamedHsBinds -> RnMS s (result, FreeVars))
212             -> RnMS s (result, FreeVars)
213
214 rnMonoBinds EmptyMonoBinds sigs thing_inside = thing_inside EmptyBinds
215
216 rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds
217   =     -- Extract all the binders in this group,
218         -- and extend current scope, inventing new names for the new binders
219         -- This also checks that the names form a set
220     bindLocatedLocalsRn (text "binding group") mbinders_w_srclocs               $ \ new_mbinders ->
221     let
222         binder_set = mkNameSet new_mbinders
223     in
224     rn_mono_binds NotTopLevel
225                   binder_set mbinds sigs        `thenRn` \ (binds,bind_fvs) ->
226
227         -- Now do the "thing inside", and deal with the free-variable calculations
228     thing_inside binds                                  `thenRn` \ (result,result_fvs) ->
229     let
230         all_fvs        = result_fvs  `unionNameSets` bind_fvs
231         net_fvs        = all_fvs `minusNameSet` binder_set
232         unused_binders = binder_set `minusNameSet` all_fvs
233     in
234     warnUnusedBinds unused_binders      `thenRn_`
235     returnRn (result, net_fvs)
236   where
237     mbinders_w_srclocs = bagToList (collectMonoBinders mbinds)
238 \end{code}
239
240
241 %************************************************************************
242 %*                                                                      *
243 %*              MonoBinds -- the main work is done here
244 %*                                                                      *
245 %************************************************************************
246
247 @rnMonoBinds@ is used by *both* top-level and nested bindings.  It
248 assumes that all variables bound in this group are already in scope.
249 This is done *either* by pass 3 (for the top-level bindings), *or* by
250 @rnNestedMonoBinds@ (for the nested ones).
251
252 \begin{code}
253 rn_mono_binds :: TopLevelFlag
254               -> NameSet                -- Binders of this group
255               -> RdrNameMonoBinds       
256               -> [RdrNameSig]           -- Signatures attached to this group
257               -> RnMS s (RenamedHsBinds,        -- 
258                          FreeVars)      -- Free variables
259
260 rn_mono_binds top_lev binders mbinds sigs
261   =
262          -- Rename the bindings, returning a MonoBindsInfo
263          -- which is a list of indivisible vertices so far as
264          -- the strongly-connected-components (SCC) analysis is concerned
265     rnBindSigs top_lev binders sigs     `thenRn` \ siglist ->
266     flattenMonoBinds siglist mbinds     `thenRn` \ mbinds_info ->
267
268          -- Do the SCC analysis
269     let edges       = mkEdges (mbinds_info `zip` [0..])
270         scc_result  = stronglyConnComp edges
271         final_binds = foldr1 ThenBinds (map reconstructCycle scc_result)
272
273          -- Deal with bound and free-var calculation
274         rhs_fvs = unionManyNameSets [fvs | (_,_,fvs,_,_) <- mbinds_info]
275     in
276     returnRn (final_binds, rhs_fvs)
277 \end{code}
278
279 @flattenMonoBinds@ is ever-so-slightly magical in that it sticks
280 unique ``vertex tags'' on its output; minor plumbing required.
281
282 \begin{code}
283 flattenMonoBinds :: [RenamedSig]                -- Signatures
284                  -> RdrNameMonoBinds
285                  -> RnMS s (Int, [FlatMonoBindsInfo])
286
287 flattenMonoBinds sigs EmptyMonoBinds = returnRn []
288
289 flattenMonoBinds sigs (AndMonoBinds bs1 bs2)
290   = flattenMonoBinds sigs bs1   `thenRn` \ flat1 ->
291     flattenMonoBinds sigs bs2   `thenRn` \ flat2 ->
292     returnRn (flat1 ++ flat2)
293
294 flattenMonoBinds sigs (PatMonoBind pat grhss_and_binds locn)
295   = pushSrcLocRn locn                   $
296     rnPat pat                           `thenRn` \ pat' ->
297     rnGRHSsAndBinds grhss_and_binds     `thenRn` \ (grhss_and_binds', fvs) ->
298
299          -- Find which things are bound in this group
300     let
301         names_bound_here = mkNameSet (collectPatBinders pat')
302         sigs_for_me      = filter ((`elemNameSet` names_bound_here) . sig_name) sigs
303         sigs_fvs         = foldr sig_fv emptyNameSet sigs_for_me
304     in
305     returnRn 
306         [(names_bound_here,
307           fvs `unionNameSets` sigs_fvs,
308           PatMonoBind pat' grhss_and_binds' locn,
309           sigs_for_me
310          )]
311
312 flattenMonoBinds sigs (FunMonoBind name inf matches locn)
313   = pushSrcLocRn locn                            $
314     mapRn (checkPrecMatch inf name) matches     `thenRn_`
315     lookupBndrRn name                           `thenRn` \ name' ->
316     mapAndUnzipRn rnMatch matches               `thenRn` \ (new_matches, fv_lists) ->
317     let
318         fvs         = unionManyNameSets fv_lists
319         sigs_for_me = filter ((name' ==) . sig_name) sigs
320         sigs_fvs    = foldr sig_fv emptyNameSet sigs_for_me
321     in
322     returnRn
323       [(unitNameSet name',
324         fvs `unionNameSets` sigs_fvs,
325         FunMonoBind name' inf new_matches locn,
326         sigs_for_me
327         )]
328 \end{code}
329
330
331 @rnMethodBinds@ is used for the method bindings of an instance
332 declaration.   like @rnMonoBinds@ but without dependency analysis.
333
334 \begin{code}
335 rnMethodBinds :: RdrNameMonoBinds -> RnMS s RenamedMonoBinds
336
337 rnMethodBinds EmptyMonoBinds = returnRn EmptyMonoBinds
338
339 rnMethodBinds (AndMonoBinds mb1 mb2)
340   = andRn AndMonoBinds (rnMethodBinds mb1)
341                        (rnMethodBinds mb2)
342
343 rnMethodBinds (FunMonoBind occname inf matches locn)
344   = pushSrcLocRn locn                              $
345     mapRn (checkPrecMatch inf occname) matches  `thenRn_`
346
347     newLocalNames [(occname, locn)]             `thenRn` \ [op_name] ->
348         -- Make a fresh local for the bound variable; it must be different
349         -- to occurrences of the same thing on the LHS, which refer to the global
350         -- selectors.
351
352     mapAndUnzipRn rnMatch matches               `thenRn` \ (new_matches, _) ->
353     returnRn (FunMonoBind op_name inf new_matches locn)
354
355 rnMethodBinds (PatMonoBind (VarPatIn occname) grhss_and_binds locn)
356   = pushSrcLocRn locn                   $
357     newLocalNames [(occname, locn)]     `thenRn` \ [op_name] ->
358     rnGRHSsAndBinds grhss_and_binds     `thenRn` \ (grhss_and_binds', _) ->
359     returnRn (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn)
360
361 -- Can't handle method pattern-bindings which bind multiple methods.
362 rnMethodBinds mbind@(PatMonoBind other_pat _ locn)
363   = pushSrcLocRn locn   $
364     failWithRn EmptyMonoBinds (methodBindErr mbind)
365 \end{code}
366
367 \begin{code}
368 -- If a SPECIALIZE pragma is of the "... = blah" form,
369 -- then we'd better make sure "blah" is taken into
370 -- acct in the dependency analysis (or we get an
371 -- unexpected out-of-scope error)! WDP 95/07
372
373 sig_fv (SpecSig _ _ (Just blah) _) acc = acc `unionNameSets` (unitNameSet blah)
374 sig_fv _                           acc = acc
375 \end{code}
376
377 %************************************************************************
378 %*                                                                      *
379 \subsection[reconstruct-deps]{Reconstructing dependencies}
380 %*                                                                      *
381 %************************************************************************
382
383 This @MonoBinds@- and @ClassDecls@-specific code is segregated here,
384 as the two cases are similar.
385
386 \begin{code}
387 reconstructCycle :: SCC FlatMonoBindsInfo
388                  -> RenamedHsBinds
389
390 reconstructCycle (AcyclicSCC (_, _, _, binds, sigs))
391   = MonoBind binds sigs NonRecursive
392
393 reconstructCycle (CyclicSCC cycle)
394   = MonoBind this_gp_binds this_gp_sigs Recursive
395   where
396     this_gp_binds      = foldr1 AndMonoBinds [binds | (_, _, _, binds, _) <- cycle]
397     this_gp_sigs       = foldr1 (++)         [sigs  | (_, _, _, _, sigs) <- cycle]
398 \end{code}
399
400 %************************************************************************
401 %*                                                                      *
402 %*      Manipulating FlatMonoBindInfo                                   *
403 %*                                                                      *
404 %************************************************************************
405
406 During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@.
407 The @RenamedMonoBinds@ is always an empty bind, a pattern binding or
408 a function binding, and has itself been dependency-analysed and
409 renamed.
410
411 \begin{code}
412 type FlatMonoBindsInfo
413   = (NameSet,                   -- Set of names defined in this vertex
414      NameSet,                   -- Set of names used in this vertex
415      RenamedMonoBinds,
416      [RenamedSig])              -- Signatures, if any, for this vertex
417
418 mkEdges :: [(FlatMonoBindsInfo, VertexTag)] -> [(FlatMonoBindsInfo, VertexTag, [VertexTag])]
419
420 mkEdges flat_info
421   = [ (info, tag, dest_vertices (nameSetToList names_used))
422     | (info@(names_defined, names_used, mbind, sigs), tag) <- flat_info
423     ]
424   where
425          -- An edge (v,v') indicates that v depends on v'
426     dest_vertices src_mentions = [ target_vertex
427                                  | ((names_defined, _, _, _), target_vertex) <- flat_info,
428                                    mentioned_name <- src_mentions,
429                                    mentioned_name `elemNameSet` names_defined
430                                  ]
431 \end{code}
432
433
434 %************************************************************************
435 %*                                                                      *
436 \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
437 %*                                                                      *
438 %************************************************************************
439
440 @rnBindSigs@ checks for: (a)~more than one sig for one thing;
441 (b)~signatures given for things not bound here; (c)~with suitably
442 flaggery, that all top-level things have type signatures.
443
444 \begin{code}
445 rnBindSigs :: TopLevelFlag
446            -> NameSet                   -- Set of names bound in this group
447            -> [RdrNameSig]
448            -> RnMS s [RenamedSig]                -- List of Sig constructors
449
450 rnBindSigs top_lev binders sigs
451   =      -- Rename the signatures
452     mapRn renameSig sigs        `thenRn` \ sigs' ->
453
454         -- Check for (a) duplicate signatures
455         --           (b) signatures for things not in this group
456         --           (c) optionally, bindings with no signature
457     let
458         (goodies, dups) = removeDups cmp_sig (filter (not.isUnboundName.sig_name) sigs')
459         not_this_group  = filter (\sig -> not (sig_name sig `elemNameSet` binders)) goodies
460         type_sig_vars   = [n | Sig n _ _ <- goodies]
461         sigs_required   = case top_lev of {TopLevel -> opt_SigsRequired; NotTopLevel -> False}
462         un_sigd_binders | sigs_required = nameSetToList binders `minusList` type_sig_vars
463                         | otherwise     = []
464     in
465     mapRn dupSigDeclErr dups                            `thenRn_`
466     mapRn unknownSigErr not_this_group                  `thenRn_`
467     mapRn (addErrRn.missingSigErr) un_sigd_binders      `thenRn_`
468
469     returnRn sigs' -- bad ones and all:
470                    -- we need bindings of *some* sort for every name
471
472
473 renameSig (Sig v ty src_loc)
474   = pushSrcLocRn src_loc $
475     lookupBndrRn v                              `thenRn` \ new_v ->
476     rnHsSigType (quotes (ppr v)) ty             `thenRn` \ new_ty ->
477     returnRn (Sig new_v new_ty src_loc)
478
479 renameSig (SpecSig v ty using src_loc)
480   = pushSrcLocRn src_loc $
481     lookupBndrRn v                      `thenRn` \ new_v ->
482     rnHsSigType (quotes (ppr v)) ty     `thenRn` \ new_ty ->
483     rn_using using                      `thenRn` \ new_using ->
484     returnRn (SpecSig new_v new_ty new_using src_loc)
485   where
486     rn_using Nothing  = returnRn Nothing
487     rn_using (Just x) = lookupOccRn x `thenRn` \ new_x ->
488                         returnRn (Just new_x)
489
490 renameSig (InlineSig v src_loc)
491   = pushSrcLocRn src_loc $
492     lookupBndrRn v              `thenRn` \ new_v ->
493     returnRn (InlineSig new_v src_loc)
494
495 renameSig (MagicUnfoldingSig v str src_loc)
496   = pushSrcLocRn src_loc $
497     lookupBndrRn v              `thenRn` \ new_v ->
498     returnRn (MagicUnfoldingSig new_v str src_loc)
499 \end{code}
500
501 Checking for distinct signatures; oh, so boring
502
503 \begin{code}
504 cmp_sig :: RenamedSig -> RenamedSig -> Ordering
505 cmp_sig (Sig n1 _ _)               (Sig n2 _ _)           = n1 `compare` n2
506 cmp_sig (InlineSig n1 _)           (InlineSig n2 _)       = n1 `compare` n2
507 cmp_sig (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `compare` n2
508 cmp_sig (SpecSig n1 ty1 _ _)       (SpecSig n2 ty2 _ _)
509   = -- may have many specialisations for one value;
510         -- but not ones that are exactly the same...
511         thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2)
512
513 cmp_sig other_1 other_2                                 -- Tags *must* be different
514   | (sig_tag other_1) _LT_ (sig_tag other_2) = LT 
515   | otherwise                                = GT
516
517 sig_tag (Sig n1 _ _)               = (ILIT(1) :: FAST_INT)
518 sig_tag (SpecSig n1 _ _ _)         = ILIT(2)
519 sig_tag (InlineSig n1 _)           = ILIT(3)
520 sig_tag (MagicUnfoldingSig n1 _ _) = ILIT(4)
521 sig_tag _                          = panic# "tag(RnBinds)"
522
523 sig_name (Sig        n _ _)        = n
524 sig_name (ClassOpSig n _ _ _)      = n
525 sig_name (SpecSig    n _ _ _)      = n
526 sig_name (InlineSig  n     _)      = n  
527 sig_name (MagicUnfoldingSig n _ _) = n
528 \end{code}
529
530 %************************************************************************
531 %*                                                                      *
532 \subsection{Error messages}
533 %*                                                                      *
534 %************************************************************************
535
536 \begin{code}
537 dupSigDeclErr (sig:sigs)
538   = pushSrcLocRn loc $
539     addErrRn (sep [ptext SLIT("more than one"), 
540                    ptext what_it_is, ptext SLIT("given for"), 
541                    quotes (ppr (sig_name sig))])
542   where
543     (what_it_is, loc) = sig_doc sig
544
545 unknownSigErr sig
546   = pushSrcLocRn loc $
547     addErrRn (sep [ptext flavour, ptext SLIT("but no definition for"),
548                    quotes (ppr (sig_name sig))])
549   where
550     (flavour, loc) = sig_doc sig
551
552 sig_doc (Sig        _ _ loc)        = (SLIT("type signature"),loc)
553 sig_doc (ClassOpSig _ _ _ loc)      = (SLIT("class-method type signature"), loc)
554 sig_doc (SpecSig    _ _ _ loc)      = (SLIT("SPECIALIZE pragma"),loc)
555 sig_doc (InlineSig  _     loc)      = (SLIT("INLINE pragma"),loc)
556 sig_doc (MagicUnfoldingSig _ _ loc) = (SLIT("MAGIC_UNFOLDING pragma"),loc)
557
558 missingSigErr var
559   = sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)]
560
561 methodBindErr mbind
562  =  hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding"))
563        4 (ppr mbind)
564 \end{code}