[project @ 2000-09-22 15:56:12 by simonpj]
[ghc-hetmet.git] / ghc / compiler / rename / RnBinds.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
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, renameSigs,
15         rnBinds,
16         unknownSigErr
17    ) where
18
19 #include "HsVersions.h"
20
21 import {-# SOURCE #-} RnSource ( rnHsSigType )
22
23 import HsSyn
24 import HsBinds          ( eqHsSig, sigName, hsSigDoc )
25 import RdrHsSyn
26 import RnHsSyn
27 import RnMonad
28 import RnExpr           ( rnMatch, rnGRHSs, rnPat, checkPrecMatch )
29 import RnEnv            ( bindLocatedLocalsRn, lookupBndrRn, 
30                           lookupGlobalOccRn, lookupSigOccRn,
31                           warnUnusedLocalBinds, mapFvRn, 
32                           FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV
33                         )
34 import CmdLineOpts      ( opt_WarnMissingSigs )
35 import Digraph          ( stronglyConnComp, SCC(..) )
36 import Name             ( OccName, Name, nameOccName, mkUnboundName, isUnboundName )
37 import NameSet
38 import RdrName          ( RdrName, rdrNameOcc  )
39 import BasicTypes       ( RecFlag(..) )
40 import List             ( partition )
41 import Bag              ( bagToList )
42 import Outputable
43 \end{code}
44
45 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
46 -- place and can be used when complaining.
47
48 The code tree received by the function @rnBinds@ contains definitions
49 in where-clauses which are all apparently mutually recursive, but which may
50 not really depend upon each other. For example, in the top level program
51 \begin{verbatim}
52 f x = y where a = x
53               y = x
54 \end{verbatim}
55 the definitions of @a@ and @y@ do not depend on each other at all.
56 Unfortunately, the typechecker cannot always check such definitions.
57 \footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
58 definitions. In Proceedings of the International Symposium on Programming,
59 Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
60 However, the typechecker usually can check definitions in which only the
61 strongly connected components have been collected into recursive bindings.
62 This is precisely what the function @rnBinds@ does.
63
64 ToDo: deal with case where a single monobinds binds the same variable
65 twice.
66
67 The vertag tag is a unique @Int@; the tags only need to be unique
68 within one @MonoBinds@, so that unique-Int plumbing is done explicitly
69 (heavy monad machinery not needed).
70
71 \begin{code}
72 type VertexTag  = Int
73 type Cycle      = [VertexTag]
74 type Edge       = (VertexTag, VertexTag)
75 \end{code}
76
77 %************************************************************************
78 %*                                                                      *
79 %* naming conventions                                                   *
80 %*                                                                      *
81 %************************************************************************
82
83 \subsection[name-conventions]{Name conventions}
84
85 The basic algorithm involves walking over the tree and returning a tuple
86 containing the new tree plus its free variables. Some functions, such
87 as those walking polymorphic bindings (HsBinds) and qualifier lists in
88 list comprehensions (@Quals@), return the variables bound in local
89 environments. These are then used to calculate the free variables of the
90 expression evaluated in these environments.
91
92 Conventions for variable names are as follows:
93 \begin{itemize}
94 \item
95 new code is given a prime to distinguish it from the old.
96
97 \item
98 a set of variables defined in @Exp@ is written @dvExp@
99
100 \item
101 a set of variables free in @Exp@ is written @fvExp@
102 \end{itemize}
103
104 %************************************************************************
105 %*                                                                      *
106 %* analysing polymorphic bindings (HsBinds, Bind, MonoBinds)            *
107 %*                                                                      *
108 %************************************************************************
109
110 \subsubsection[dep-HsBinds]{Polymorphic bindings}
111
112 Non-recursive expressions are reconstructed without any changes at top
113 level, although their component expressions may have to be altered.
114 However, non-recursive expressions are currently not expected as
115 \Haskell{} programs, and this code should not be executed.
116
117 Monomorphic bindings contain information that is returned in a tuple
118 (a @FlatMonoBindsInfo@) containing:
119
120 \begin{enumerate}
121 \item
122 a unique @Int@ that serves as the ``vertex tag'' for this binding.
123
124 \item
125 the name of a function or the names in a pattern. These are a set
126 referred to as @dvLhs@, the defined variables of the left hand side.
127
128 \item
129 the free variables of the body. These are referred to as @fvBody@.
130
131 \item
132 the definition's actual code. This is referred to as just @code@.
133 \end{enumerate}
134
135 The function @nonRecDvFv@ returns two sets of variables. The first is
136 the set of variables defined in the set of monomorphic bindings, while the
137 second is the set of free variables in those bindings.
138
139 The set of variables defined in a non-recursive binding is just the
140 union of all of them, as @union@ removes duplicates. However, the
141 free variables in each successive set of cumulative bindings is the
142 union of those in the previous set plus those of the newest binding after
143 the defined variables of the previous set have been removed.
144
145 @rnMethodBinds@ deals only with the declarations in class and
146 instance declarations.  It expects only to see @FunMonoBind@s, and
147 it expects the global environment to contain bindings for the binders
148 (which are all class operations).
149
150 %************************************************************************
151 %*                                                                      *
152 \subsubsection{ Top-level bindings}
153 %*                                                                      *
154 %************************************************************************
155
156 @rnTopBinds@ assumes that the environment already
157 contains bindings for the binders of this particular binding.
158
159 \begin{code}
160 rnTopBinds    :: RdrNameHsBinds -> RnMS (RenamedHsBinds, FreeVars)
161
162 rnTopBinds EmptyBinds                     = returnRn (EmptyBinds, emptyFVs)
163 rnTopBinds (MonoBind bind sigs _)         = rnTopMonoBinds bind sigs
164   -- The parser doesn't produce other forms
165
166
167 rnTopMonoBinds mbinds sigs
168  =  mapRn lookupBndrRn binder_rdr_names         `thenRn` \ binder_names ->
169     let
170         bndr_name_set = mkNameSet binder_names
171     in
172     renameSigs (okBindSig bndr_name_set) sigs `thenRn` \ (siglist, sig_fvs) ->
173     let
174         type_sig_vars   = [n | Sig n _ _ <- siglist]
175         un_sigd_binders | opt_WarnMissingSigs = nameSetToList (delListFromNameSet bndr_name_set type_sig_vars)
176                         | otherwise           = []
177     in
178     mapRn_ (addWarnRn.missingSigWarn) un_sigd_binders   `thenRn_`
179
180     rn_mono_binds siglist mbinds                   `thenRn` \ (final_binds, bind_fvs) ->
181     returnRn (final_binds, bind_fvs `plusFV` sig_fvs)
182   where
183     binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds))
184 \end{code}
185
186 %************************************************************************
187 %*                                                                      *
188 %*              Nested binds
189 %*                                                                      *
190 %************************************************************************
191
192 \subsubsection{Nested binds}
193
194 @rnMonoBinds@
195 \begin{itemize}
196 \item collects up the binders for this declaration group,
197 \item checks that they form a set
198 \item extends the environment to bind them to new local names
199 \item calls @rnMonoBinds@ to do the real work
200 \end{itemize}
201 %
202 \begin{code}
203 rnBinds       :: RdrNameHsBinds 
204               -> (RenamedHsBinds -> RnMS (result, FreeVars))
205               -> RnMS (result, FreeVars)
206
207 rnBinds EmptyBinds             thing_inside = thing_inside EmptyBinds
208 rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside
209   -- the parser doesn't produce other forms
210
211
212 rnMonoBinds :: RdrNameMonoBinds 
213             -> [RdrNameSig]
214             -> (RenamedHsBinds -> RnMS (result, FreeVars))
215             -> RnMS (result, FreeVars)
216
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 "a binding group") 
222                         mbinders_w_srclocs      $ \ new_mbinders ->
223     let
224         binder_set = mkNameSet new_mbinders
225     in
226         -- Rename the signatures
227     renameSigs (okBindSig binder_set) sigs      `thenRn` \ (siglist, sig_fvs) ->
228
229         -- Report the fixity declarations in this group that 
230         -- don't refer to any of the group's binders.
231         -- Then install the fixity declarations that do apply here
232         -- Notice that they scope over thing_inside too
233     let
234         fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- siglist ]
235     in
236     extendFixityEnv fixity_sigs $
237
238     rn_mono_binds siglist mbinds           `thenRn` \ (binds, bind_fvs) ->
239
240     -- Now do the "thing inside", and deal with the free-variable calculations
241     thing_inside binds                     `thenRn` \ (result,result_fvs) ->
242     let
243         all_fvs        = result_fvs `plusFV` bind_fvs `plusFV` sig_fvs
244         unused_binders = nameSetToList (binder_set `minusNameSet` all_fvs)
245     in
246     warnUnusedLocalBinds unused_binders `thenRn_`
247     returnRn (result, delListFromNameSet all_fvs new_mbinders)
248   where
249     mbinders_w_srclocs = bagToList (collectMonoBinders mbinds)
250 \end{code}
251
252
253 %************************************************************************
254 %*                                                                      *
255 \subsubsection{         MonoBinds -- the main work is done here}
256 %*                                                                      *
257 %************************************************************************
258
259 @rn_mono_binds@ is used by {\em both} top-level and nested bindings.
260 It assumes that all variables bound in this group are already in scope.
261 This is done {\em either} by pass 3 (for the top-level bindings),
262 {\em or} by @rnMonoBinds@ (for the nested ones).
263
264 \begin{code}
265 rn_mono_binds :: [RenamedSig]           -- Signatures attached to this group
266               -> RdrNameMonoBinds       
267               -> RnMS (RenamedHsBinds,  -- 
268                          FreeVars)      -- Free variables
269
270 rn_mono_binds siglist mbinds
271   =
272          -- Rename the bindings, returning a MonoBindsInfo
273          -- which is a list of indivisible vertices so far as
274          -- the strongly-connected-components (SCC) analysis is concerned
275     flattenMonoBinds siglist mbinds             `thenRn` \ mbinds_info ->
276
277          -- Do the SCC analysis
278     let 
279         edges       = mkEdges (mbinds_info `zip` [(0::Int)..])
280         scc_result  = stronglyConnComp edges
281         final_binds = foldr (ThenBinds . reconstructCycle) EmptyBinds scc_result
282
283          -- Deal with bound and free-var calculation
284         rhs_fvs = plusFVs [fvs | (_,fvs,_,_) <- mbinds_info]
285     in
286     returnRn (final_binds, rhs_fvs)
287 \end{code}
288
289 @flattenMonoBinds@ is ever-so-slightly magical in that it sticks
290 unique ``vertex tags'' on its output; minor plumbing required.
291
292 Sigh --- need to pass along the signatures for the group of bindings,
293 in case any of them \fbox{\ ???\ } 
294
295 \begin{code}
296 flattenMonoBinds :: [RenamedSig]                -- Signatures
297                  -> RdrNameMonoBinds
298                  -> RnMS [FlatMonoBindsInfo]
299
300 flattenMonoBinds sigs EmptyMonoBinds = returnRn []
301
302 flattenMonoBinds sigs (AndMonoBinds bs1 bs2)
303   = flattenMonoBinds sigs bs1   `thenRn` \ flat1 ->
304     flattenMonoBinds sigs bs2   `thenRn` \ flat2 ->
305     returnRn (flat1 ++ flat2)
306
307 flattenMonoBinds sigs (PatMonoBind pat grhss locn)
308   = pushSrcLocRn locn                   $
309     rnPat pat                           `thenRn` \ (pat', pat_fvs) ->
310
311          -- Find which things are bound in this group
312     let
313         names_bound_here = mkNameSet (collectPatBinders pat')
314     in
315     sigsForMe names_bound_here sigs     `thenRn` \ sigs_for_me ->
316     rnGRHSs grhss                       `thenRn` \ (grhss', fvs) ->
317     returnRn 
318         [(names_bound_here,
319           fvs `plusFV` pat_fvs,
320           PatMonoBind pat' grhss' locn,
321           sigs_for_me
322          )]
323
324 flattenMonoBinds sigs (FunMonoBind name inf matches locn)
325   = pushSrcLocRn locn                                   $
326     lookupBndrRn name                                   `thenRn` \ new_name ->
327     let
328         names_bound_here = unitNameSet new_name
329     in
330     sigsForMe names_bound_here sigs                     `thenRn` \ sigs_for_me ->
331     mapFvRn rnMatch matches                             `thenRn` \ (new_matches, fvs) ->
332     mapRn_ (checkPrecMatch inf new_name) new_matches    `thenRn_`
333     returnRn
334       [(unitNameSet new_name,
335         fvs,
336         FunMonoBind new_name inf new_matches locn,
337         sigs_for_me
338         )]
339
340
341 sigsForMe names_bound_here sigs
342   = foldlRn check [] (filter (sigForThisGroup names_bound_here) sigs)
343   where
344     check sigs sig = case filter (eqHsSig sig) sigs of
345                         []    -> returnRn (sig:sigs)
346                         other -> dupSigDeclErr sig      `thenRn_`
347                                  returnRn sigs
348 \end{code}
349
350
351 @rnMethodBinds@ is used for the method bindings of a class and an instance
352 declaration.   Like @rnMonoBinds@ but without dependency analysis.
353
354 NOTA BENE: we record each {\em binder} of a method-bind group as a free variable.
355 That's crucial when dealing with an instance decl:
356 \begin{verbatim}
357         instance Foo (T a) where
358            op x = ...
359 \end{verbatim}
360 This might be the {\em sole} occurrence of @op@ for an imported class @Foo@,
361 and unless @op@ occurs we won't treat the type signature of @op@ in the class
362 decl for @Foo@ as a source of instance-decl gates.  But we should!  Indeed,
363 in many ways the @op@ in an instance decl is just like an occurrence, not
364 a binder.
365
366 \begin{code}
367 rnMethodBinds :: RdrNameMonoBinds -> RnMS (RenamedMonoBinds, FreeVars)
368
369 rnMethodBinds EmptyMonoBinds = returnRn (EmptyMonoBinds, emptyFVs)
370
371 rnMethodBinds (AndMonoBinds mb1 mb2)
372   = rnMethodBinds mb1   `thenRn` \ (mb1', fvs1) ->
373     rnMethodBinds mb2   `thenRn` \ (mb2', fvs2) ->
374     returnRn (mb1' `AndMonoBinds` mb2', fvs1 `plusFV` fvs2)
375
376 rnMethodBinds (FunMonoBind name inf matches locn)
377   = pushSrcLocRn locn                                   $
378
379     lookupGlobalOccRn name                              `thenRn` \ sel_name -> 
380         -- We use the selector name as the binder
381
382     mapFvRn rnMatch matches                             `thenRn` \ (new_matches, fvs) ->
383     mapRn_ (checkPrecMatch inf sel_name) new_matches    `thenRn_`
384     returnRn (FunMonoBind sel_name inf new_matches locn, fvs `addOneFV` sel_name)
385
386 -- Can't handle method pattern-bindings which bind multiple methods.
387 rnMethodBinds mbind@(PatMonoBind other_pat _ locn)
388   = pushSrcLocRn locn   $
389     failWithRn (EmptyMonoBinds, emptyFVs) (methodBindErr mbind)
390 \end{code}
391
392
393 %************************************************************************
394 %*                                                                      *
395 \subsection[reconstruct-deps]{Reconstructing dependencies}
396 %*                                                                      *
397 %************************************************************************
398
399 This @MonoBinds@- and @ClassDecls@-specific code is segregated here,
400 as the two cases are similar.
401
402 \begin{code}
403 reconstructCycle :: SCC FlatMonoBindsInfo
404                  -> RenamedHsBinds
405
406 reconstructCycle (AcyclicSCC (_, _, binds, sigs))
407   = MonoBind binds sigs NonRecursive
408
409 reconstructCycle (CyclicSCC cycle)
410   = MonoBind this_gp_binds this_gp_sigs Recursive
411   where
412     this_gp_binds      = foldr1 AndMonoBinds [binds | (_, _, binds, _) <- cycle]
413     this_gp_sigs       = foldr1 (++)         [sigs  | (_, _, _, sigs) <- cycle]
414 \end{code}
415
416 %************************************************************************
417 %*                                                                      *
418 \subsubsection{ Manipulating FlatMonoBindInfo}
419 %*                                                                      *
420 %************************************************************************
421
422 During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@.
423 The @RenamedMonoBinds@ is always an empty bind, a pattern binding or
424 a function binding, and has itself been dependency-analysed and
425 renamed.
426
427 \begin{code}
428 type FlatMonoBindsInfo
429   = (NameSet,                   -- Set of names defined in this vertex
430      NameSet,                   -- Set of names used in this vertex
431      RenamedMonoBinds,
432      [RenamedSig])              -- Signatures, if any, for this vertex
433
434 mkEdges :: [(FlatMonoBindsInfo, VertexTag)] -> [(FlatMonoBindsInfo, VertexTag, [VertexTag])]
435
436 mkEdges flat_info
437   = [ (info, tag, dest_vertices (nameSetToList names_used))
438     | (info@(names_defined, names_used, mbind, sigs), tag) <- flat_info
439     ]
440   where
441          -- An edge (v,v') indicates that v depends on v'
442     dest_vertices src_mentions = [ target_vertex
443                                  | ((names_defined, _, _, _), target_vertex) <- flat_info,
444                                    mentioned_name <- src_mentions,
445                                    mentioned_name `elemNameSet` names_defined
446                                  ]
447 \end{code}
448
449
450 %************************************************************************
451 %*                                                                      *
452 \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
453 %*                                                                      *
454 %************************************************************************
455
456 @renameSigs@ checks for:
457 \begin{enumerate}
458 \item more than one sig for one thing;
459 \item signatures given for things not bound here;
460 \item with suitably flaggery, that all top-level things have type signatures.
461 \end{enumerate}
462 %
463 At the moment we don't gather free-var info from the types in
464 signatures.  We'd only need this if we wanted to report unused tyvars.
465
466 \begin{code}
467 renameSigs ::  (RenamedSig -> Bool)             -- OK-sig predicate
468             -> [RdrNameSig]
469             -> RnMS ([RenamedSig], FreeVars)
470
471 renameSigs ok_sig [] = returnRn ([], emptyFVs)  -- Common shortcut
472
473 renameSigs ok_sig sigs
474   =      -- Rename the signatures
475     mapFvRn renameSig sigs      `thenRn` \ (sigs', fvs) ->
476
477         -- Check for (a) duplicate signatures
478         --           (b) signatures for things not in this group
479     let
480         in_scope         = filter is_in_scope sigs'
481         is_in_scope sig  = case sigName sig of
482                                 Just n  -> not (isUnboundName n)
483                                 Nothing -> True
484         (goods, bads)    = partition ok_sig in_scope
485     in
486     mapRn_ unknownSigErr bads                   `thenRn_`
487     returnRn (goods, fvs)
488
489 -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
490 -- because this won't work for:
491 --      instance Foo T where
492 --        {-# INLINE op #-}
493 --        Baz.op = ...
494 -- We'll just rename the INLINE prag to refer to whatever other 'op'
495 -- is in scope.  (I'm assuming that Baz.op isn't in scope unqualified.)
496 -- Doesn't seem worth much trouble to sort this.
497
498 renameSig :: Sig RdrName -> RnMS (Sig Name, FreeVars)
499
500 renameSig (Sig v ty src_loc)
501   = pushSrcLocRn src_loc $
502     lookupSigOccRn v                            `thenRn` \ new_v ->
503     rnHsSigType (quotes (ppr v)) ty             `thenRn` \ (new_ty,fvs) ->
504     returnRn (Sig new_v new_ty src_loc, fvs `addOneFV` new_v)
505
506 renameSig (SpecInstSig ty src_loc)
507   = pushSrcLocRn src_loc $
508     rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ (new_ty, fvs) ->
509     returnRn (SpecInstSig new_ty src_loc, fvs)
510
511 renameSig (SpecSig v ty src_loc)
512   = pushSrcLocRn src_loc $
513     lookupSigOccRn v                    `thenRn` \ new_v ->
514     rnHsSigType (quotes (ppr v)) ty     `thenRn` \ (new_ty,fvs) ->
515     returnRn (SpecSig new_v new_ty src_loc, fvs `addOneFV` new_v)
516
517 renameSig (FixSig (FixitySig v fix src_loc))
518   = pushSrcLocRn src_loc $
519     lookupSigOccRn v            `thenRn` \ new_v ->
520     returnRn (FixSig (FixitySig new_v fix src_loc), unitFV new_v)
521
522 renameSig (InlineSig v p src_loc)
523   = pushSrcLocRn src_loc $
524     lookupSigOccRn v            `thenRn` \ new_v ->
525     returnRn (InlineSig new_v p src_loc, unitFV new_v)
526
527 renameSig (NoInlineSig v p src_loc)
528   = pushSrcLocRn src_loc $
529     lookupSigOccRn v            `thenRn` \ new_v ->
530     returnRn (NoInlineSig new_v p src_loc, unitFV new_v)
531 \end{code}
532
533 \begin{code}
534 renameIE :: (RdrName -> RnMS Name) -> IE RdrName -> RnMS (IE Name, FreeVars)
535 renameIE lookup_occ_nm (IEVar v)
536   = lookup_occ_nm v             `thenRn` \ new_v ->
537     returnRn (IEVar new_v, unitFV new_v)
538
539 renameIE lookup_occ_nm (IEThingAbs v)
540   = lookup_occ_nm v             `thenRn` \ new_v ->
541     returnRn (IEThingAbs new_v, unitFV new_v)
542
543 renameIE lookup_occ_nm (IEThingAll v)
544   = lookup_occ_nm v             `thenRn` \ new_v ->
545     returnRn (IEThingAll new_v, unitFV new_v)
546
547 renameIE lookup_occ_nm (IEThingWith v vs)
548   = lookup_occ_nm v             `thenRn` \ new_v ->
549     mapRn lookup_occ_nm vs      `thenRn` \ new_vs ->
550     returnRn (IEThingWith new_v new_vs, plusFVs [ unitFV x | x <- new_v:new_vs ])
551
552 renameIE lookup_occ_nm (IEModuleContents m)
553   = returnRn (IEModuleContents m, emptyFVs)
554 \end{code}
555
556
557 %************************************************************************
558 %*                                                                      *
559 \subsection{Error messages}
560 %*                                                                      *
561 %************************************************************************
562
563 \begin{code}
564 dupSigDeclErr sig
565   = pushSrcLocRn loc $
566     addErrRn (sep [ptext SLIT("Duplicate") <+> ptext what_it_is <> colon,
567                    ppr sig])
568   where
569     (what_it_is, loc) = hsSigDoc sig
570
571 unknownSigErr sig
572   = pushSrcLocRn loc $
573     addErrRn (sep [ptext SLIT("Misplaced") <+> ptext what_it_is <> colon,
574                    ppr sig])
575   where
576     (what_it_is, loc) = hsSigDoc sig
577
578 missingSigWarn var
579   = sep [ptext SLIT("definition but no type signature for"), quotes (ppr var)]
580
581 methodBindErr mbind
582  =  hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding"))
583        4 (ppr mbind)
584 \end{code}