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