2 % (c) The GRASP Project, Glasgow University, 1992-1995
4 \section[Rename2]{Second renaming pass: boil down to non-duplicated info}
7 #include "HsVersions.h"
13 Module, Bag, ProtoNamePat(..), InPat,
14 PprStyle, Pretty(..), PrettyRep, ProtoName
17 IMPORT_Trace -- ToDo: rm (debugging)
22 import Errors ( dupNamesErr, Error(..) )
23 import HsCore -- ****** NEED TO SEE CONSTRUCTORS ******
24 import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
25 import HsTypes ( cmpMonoType, pprParendMonoType )
26 import IdInfo ( DeforestInfo(..) )
27 import Maybes ( Maybe(..) )
30 import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
34 This pass removes duplicate declarations. Duplicates can arise when
35 two imported interface have a signature (or whatever) for the same
36 thing. We check that the two are consistent and then drop one.
38 For preference, if one is declared in this module and the other is
39 imported, we keep the former; in the case of an instance decl or type
40 decl, the local version has a lot more information which we must not
43 Similarly, if one has interesting pragmas and one has not, we keep the
46 The notion of ``duplicate'' includes an imported signature and a
47 binding in this module. In this case, the signature is discarded.
48 See note below about how this should be improved.
50 ToDo: There are still known cases in which we blithely consider two
51 declarations to be ``duplicates'' and we then select one of them, {\em
52 without} actually checking that they contain the same information!
53 [WDP 93/8/16] [Improved, at least WDP 93/08/26]
56 rnModule2 :: ProtoNameModule -> Rn12M ProtoNameModule
58 rnModule2 (Module mod_name exports imports fixes
59 ty_decls absty_sigs class_decls inst_decls specinst_sigs
60 defaults binds int_sigs src_loc)
62 = uniquefy mod_name cmpFix selFix fixes
65 uniquefy mod_name cmpTys selTys ty_decls
66 `thenRn12` \ ty_decls ->
68 uniquefy mod_name cmpTySigs selTySigs absty_sigs
69 `thenRn12` \ absty_sigs ->
71 uniquefy mod_name cmpClassDecl selClass class_decls
72 `thenRn12` \ class_decls ->
74 uniquefy mod_name cmpInst selInst inst_decls
75 `thenRn12` \ inst_decls ->
77 uniquefy mod_name cmpSpecInstSigs selSpecInstSigs specinst_sigs
78 `thenRn12` \ specinst_sigs ->
80 -- From the imported signatures discard any which are for
81 -- variables bound in this module.
82 -- But, be wary of those that *clash* with those for this
84 -- Note that we want to do this properly later (ToDo) because imported
85 -- signatures may differ from those declared in the module itself.
87 rm_sigs_for_here mod_name int_sigs
88 `thenRn12` \ non_here_int_sigs ->
90 uniquefy mod_name cmpSig selSig non_here_int_sigs
91 `thenRn12` \ int_sigs ->
94 exports -- export and import lists are passed along
95 imports -- for checking in Rename3; no other reason
107 top_level_binders = collectTopLevelBinders binds
109 rm_sigs_for_here :: FAST_STRING -> [ProtoNameSig] -> Rn12M [ProtoNameSig]
110 -- NB: operates only on interface signatures, so don't
111 -- need to worry about user-pragmas, etc.
113 rm_sigs_for_here mod_name [] = returnRn12 []
115 rm_sigs_for_here mod_name (sig@(Sig name _ _ src_loc) : more_sigs)
116 = rm_sigs_for_here mod_name more_sigs `thenRn12` \ rest_sigs ->
118 if not (name `elemByLocalNames` top_level_binders) then -- no name clash...
119 returnRn12 (sig : rest_sigs)
121 else -- name clash...
122 if name `elemProtoNames` top_level_binders
123 && name_for_this_module name then
124 -- the very same thing; just drop it
127 -- a different thing with the same name (due to renaming?)
128 -- ToDo: locations need improving
129 report_dup "(renamed?) variable"
130 name src_loc name mkUnknownSrcLoc
133 name_for_this_module (Imp m _ _ _) = m == mod_name
134 name_for_this_module other = True
137 %************************************************************************
139 \subsection[FixityDecls-Rename2]{Functions for @FixityDecls@}
141 %************************************************************************
144 cmpFix :: ProtoNameFixityDecl -> ProtoNameFixityDecl -> TAG_
146 cmpFix (InfixL n1 i1) (InfixL n2 i2) = n1 `cmpProtoName` n2
147 cmpFix (InfixL n1 i1) other = LT_
148 cmpFix (InfixR n1 i1) (InfixR n2 i2) = n1 `cmpProtoName` n2
149 cmpFix (InfixR n1 i1) (InfixN n2 i2) = LT_
150 cmpFix (InfixN n1 i1) (InfixN n2 i2) = n1 `cmpProtoName` n2
154 We are pretty un-fussy about which FixityDecl we keep.
157 selFix :: ProtoNameFixityDecl -> ProtoNameFixityDecl -> Rn12M ProtoNameFixityDecl
158 selFix f1 f2 = returnRn12 f1
161 %************************************************************************
163 \subsection[TyDecls-Rename2]{Functions for @TyDecls@}
165 %************************************************************************
168 cmpTys :: ProtoNameTyDecl -> ProtoNameTyDecl -> TAG_
170 cmpTys (TyData _ n1 _ _ _ _ _) (TyData _ n2 _ _ _ _ _) = cmpProtoName n1 n2
171 cmpTys (TyData _ n1 _ _ _ _ _) other = LT_
172 cmpTys (TySynonym n1 _ _ _ _) (TySynonym n2 _ _ _ _) = cmpProtoName n1 n2
177 selTys :: ProtoNameTyDecl -> ProtoNameTyDecl
178 -> Rn12M ProtoNameTyDecl
180 -- Note: we could check these more closely.
181 -- NB: It would be a mistake to cross-check derivings,
182 -- because we don't preserve those in interfaces.
184 selTys td1@(TyData c name1 tvs cons1 ds pragmas1 locn1)
185 td2@(TyData _ name2 _ cons2 _ pragmas2 locn2)
186 = selByBetterName "algebraic datatype"
187 name1 pragmas1 locn1 td1
188 name2 pragmas2 locn2 td2
189 (\ p -> TyData c name1 tvs cons1 ds p locn1)
192 selTys ts1@(TySynonym name1 tvs expand1 pragmas1 locn1)
193 ts2@(TySynonym name2 _ expand2 pragmas2 locn2)
194 = selByBetterName "type synonym"
195 name1 pragmas1 locn1 ts1
196 name2 pragmas2 locn2 ts2
197 (\ p -> TySynonym name1 tvs expand1 p locn1)
201 If only one is ``abstract'' (no condecls), we take the other.
203 Next, we check that they don't have differing lists of data
204 constructors (what a disaster if those get through...); then we do a
205 similar thing using pragmatic info.
208 chooser_TyData wout pragmas1 locn1 td1@(TyData _ name1 _ cons1 _ _ _)
209 pragmas2 locn2 td2@(TyData _ name2 _ cons2 _ _ _)
211 td1_abstract = null cons1
212 td2_abstract = null cons2
214 choose_by_pragmas = sub_chooser pragmas1 pragmas2
216 if td1_abstract && td2_abstract then
219 else if td1_abstract then
222 else if td2_abstract then
225 else if not (eqConDecls cons1 cons2) then
226 report_dup "algebraic datatype (mismatched data constuctors)"
227 name1 locn1 name2 locn2 td1
229 sub_chooser pragmas1 pragmas2
231 sub_chooser (DataPragmas [] []) b = returnRn12 (wout b)
232 sub_chooser a (DataPragmas [] []) = returnRn12 (wout a)
233 sub_chooser a@(DataPragmas cons1 specs1) (DataPragmas cons2 specs2)
234 = if not (eqConDecls cons1 cons2) then
235 pprTrace "Mismatched info in DATA pragmas:\n"
236 (ppAbove (ppr PprDebug cons1) (ppr PprDebug cons2)) (
237 returnRn12 (wout (DataPragmas [] []))
239 else if not (eq_data_specs specs1 specs2) then
240 pprTrace "Mismatched specialisation info in DATA pragmas:\n"
241 (ppAbove (ppr_data_specs specs1) (ppr_data_specs specs2)) (
242 returnRn12 (wout (DataPragmas [] []))
245 returnRn12 (wout a) -- same, pick one
247 -- ToDo: Should we use selByBetterName ???
248 -- ToDo: Report errors properly and recover quietly ???
250 -- ToDo: Should we merge specialisations ???
252 eq_data_specs [] [] = True
253 eq_data_specs (spec1:specs1) (spec2:specs2)
254 = eq_spec spec1 spec2 && eq_data_specs specs1 specs2
255 eq_data_specs _ _ = False
257 eq_spec spec1 spec2 = case cmp_spec spec1 spec2 of { EQ_ -> True; _ -> False}
260 = ppBesides [ppStr "_SPECIALISE_ ", pp_the_list [
261 ppCat [ppLbrack, ppInterleave ppComma (map pp_maybe ty_maybes), ppRbrack]
262 | ty_maybes <- specs ]]
265 pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
267 pp_maybe Nothing = pp_NONE
268 pp_maybe (Just ty) = pprParendMonoType PprDebug ty
270 pp_NONE = ppStr "_N_"
273 Sort of similar deal on synonyms: this is the time to check that the
274 expansions are really the same; otherwise, we use the pragmas.
277 chooser_TySynonym wout pragmas1 locn1 ts1@(TySynonym name1 _ expand1 _ _)
278 pragmas2 locn2 ts2@(TySynonym name2 _ expand2 _ _)
279 = if not (eqMonoType expand1 expand2) then
280 report_dup "type synonym" name1 locn1 name2 locn2 ts1
282 sub_chooser pragmas1 pragmas2
284 sub_chooser NoTypePragmas b = returnRn12 (wout b)
285 sub_chooser a NoTypePragmas = returnRn12 (wout a)
286 sub_chooser a _ = returnRn12 (wout a) -- same, just pick one
289 %************************************************************************
291 \subsection[DataTypeSigs-Rename2]{Functions for @DataTypeSigs@}
293 %************************************************************************
296 cmpTySigs :: ProtoNameDataTypeSig -> ProtoNameDataTypeSig -> TAG_
298 cmpTySigs (AbstractTypeSig n1 _) (AbstractTypeSig n2 _)
300 cmpTySigs (SpecDataSig n1 ty1 _) (SpecDataSig n2 ty2 _)
301 = case cmpProtoName n1 n2 of
302 EQ_ -> LT_ -- multiple SPECIALIZE data pragmas allowed
304 cmpTySigs (AbstractTypeSig n1 _) (SpecDataSig n2 _ _)
306 cmpTySigs (SpecDataSig n1 _ _) (AbstractTypeSig n2 _)
309 selTySigs :: ProtoNameDataTypeSig
310 -> ProtoNameDataTypeSig
311 -> Rn12M ProtoNameDataTypeSig
313 selTySigs s1@(AbstractTypeSig n1 locn1) s2@(AbstractTypeSig n2 locn2)
314 = selByBetterName "ABSTRACT user-pragma"
319 bottom = panic "Rename2:selTySigs:AbstractTypeSig"
321 selTySigs s1@(SpecDataSig n1 ty1 locn1) s2@(SpecDataSig n2 ty2 locn2)
322 = selByBetterName "ABSTRACT user-pragma"
327 bottom = panic "Rename2:selTySigs:SpecDataSig"
330 %************************************************************************
332 \subsection[ClassDecl-Rename2]{Functions for @ClassDecls@}
334 %************************************************************************
337 cmpClassDecl :: ProtoNameClassDecl -> ProtoNameClassDecl -> TAG_
339 cmpClassDecl (ClassDecl _ n1 _ _ _ _ _) (ClassDecl _ n2 _ _ _ _ _)
342 selClass :: ProtoNameClassDecl -> ProtoNameClassDecl
343 -> Rn12M ProtoNameClassDecl
345 selClass cd1@(ClassDecl ctxt n1 tv sigs bs pragmas1 locn1)
346 cd2@(ClassDecl _ n2 _ _ _ pragmas2 locn2)
347 = selByBetterName "class"
348 n1 pragmas1 locn1 cd1
349 n2 pragmas2 locn2 cd2
350 (\ p -> ClassDecl ctxt n1 tv sigs bs p locn1)
355 chooser_Class wout NoClassPragmas _ _ b _ _ = returnRn12 (wout b)
356 chooser_Class wout a _ _ NoClassPragmas _ _ = returnRn12 (wout a)
358 chooser_Class wout sd1@(SuperDictPragmas gs1) l1 _ sd2@(SuperDictPragmas gs2) l2 _
359 = if length gs1 /= length gs2 then -- urgh
360 returnRn12 (wout NoClassPragmas)
362 recoverQuietlyRn12 [{-no gen prags-}] (
363 zipWithRn12 choose_prag gs1 gs2
364 ) `thenRn12` \ new_gprags ->
366 if null new_gprags then
367 pprTrace "tossed all SuperDictPragmas (rename2):"
368 (ppAbove (ppr PprDebug sd1) (ppr PprDebug sd2))
371 SuperDictPragmas new_gprags
374 choose_prag g1 g2 = selGenPragmas g1 l1 g2 l2
377 %************************************************************************
379 \subsection[InstDecls-Rename2]{Functions for @InstDecls@}
381 %************************************************************************
384 cmpInst :: ProtoNameInstDecl -> ProtoNameInstDecl -> TAG_
386 cmpInst (InstDecl _ c1 ty1 _ _ _ _ _ _ _) (InstDecl _ c2 ty2 _ _ _ _ _ _ _)
387 = case cmpProtoName c1 c2 of
388 EQ_ -> cmpInstanceTypes ty1 ty2
392 Select the instance declaration from the module (rather than an
393 interface), if it exists.
396 selInst :: ProtoNameInstDecl -> ProtoNameInstDecl
397 -> Rn12M ProtoNameInstDecl
399 selInst i1@(InstDecl ctxt c ty bs from_here1 orig_mod1 infor_mod1 uprags pragmas1 locn1)
400 i2@(InstDecl _ _ _ _ from_here2 orig_mod2 infor_mod2 _ pragmas2 locn2)
402 have_orig_mod1 = not (_NULL_ orig_mod1)
403 have_orig_mod2 = not (_NULL_ orig_mod2)
405 choose_no1 = returnRn12 i1
406 choose_no2 = returnRn12 i2
408 -- generally: try to keep the locally-defined instance decl
410 if from_here1 && from_here2 then
411 -- If they are both from this module, don't throw either away,
412 -- otherwise we silently discard erroneous duplicates
413 trace ("selInst: duplicate instance in this module (ToDo: msg!)")
416 else if from_here1 then
417 if ( have_orig_mod1 && have_orig_mod2 && orig_mod1 /= orig_mod2 ) then
418 trace ("selInst: instance in this module also defined somewhere else! (ToDo: msg!)")
423 else if from_here2 then
424 if ( have_orig_mod1 && have_orig_mod2 && orig_mod1 /= orig_mod2 ) then
425 trace ("selInst: instance in this module also defined somewhere else! (ToDo: msg!)")
430 else -- it's definitely an imported instance;
431 -- first, a quick sanity check...
432 if ( have_orig_mod1 && have_orig_mod2 && orig_mod1 /= orig_mod2 ) then
433 trace ("selInst: `same' instances coming in from two modules! (ToDo: msg!)")
434 choose_no2 -- arbitrary
436 -- now we *cheat*: so we can use the "informing module" stuff
437 -- in "selByBetterName", we *make up* some ProtoNames for
438 -- these instance decls
440 ii = SLIT("!*INSTANCE*!")
441 n1 = Imp orig_mod1 ii [infor_mod1] ii
442 n2 = Imp orig_mod2 ii [infor_mod2] ii
444 selByBetterName "instance"
447 (\ p -> InstDecl ctxt c ty bs from_here1 orig_mod1 infor_mod1
453 chooser_Inst wout iprags1 loc1 i1 iprags2 loc2 i2
454 = chk_pragmas iprags1 iprags2
457 chk_pragmas NoInstancePragmas b = returnRn12 (wout b)
458 chk_pragmas a NoInstancePragmas = returnRn12 (wout a)
460 -- SimpleInstance pragmas meet: choose by GenPragmas
461 chk_pragmas (SimpleInstancePragma gprags1) (SimpleInstancePragma gprags2)
462 = recoverQuietlyRn12 NoGenPragmas (
463 selGenPragmas gprags1 loc1 gprags2 loc2
464 ) `thenRn12` \ new_prags ->
467 NoGenPragmas -> NoInstancePragmas -- bottled out
468 _ -> SimpleInstancePragma new_prags
471 -- SimpleInstance pragma meets anything else... take the "else"
472 chk_pragmas (SimpleInstancePragma _) b = returnRn12 (wout b)
473 chk_pragmas a (SimpleInstancePragma _) = returnRn12 (wout a)
475 chk_pragmas (ConstantInstancePragma gp1 prs1) (ConstantInstancePragma gp2 prs2)
476 = recoverQuietlyRn12 NoGenPragmas (
477 selGenPragmas gp1 loc1 gp2 loc2
478 ) `thenRn12` \ dfun_prags ->
480 recoverQuietlyRn12 [] (
481 selNamePragmaPairs prs1 loc1 prs2 loc2
482 ) `thenRn12` \ new_pairs ->
485 if null new_pairs then -- bottled out
487 NoGenPragmas -> NoInstancePragmas -- doubly bottled out
488 _ -> SimpleInstancePragma dfun_prags
490 ConstantInstancePragma dfun_prags new_pairs
493 -- SpecialisedInstancePragmas: choose by gens, then specialisations
494 chk_pragmas a@(SpecialisedInstancePragma _ _) (SpecialisedInstancePragma _ _)
495 = trace "not checking two SpecialisedInstancePragma pragmas!" (returnRn12 (wout a))
497 chk_pragmas other1 other2 -- oops, bad mismatch
498 = pRAGMA_ERROR "instance pragmas" (wout other1) -- ToDo: msg
501 %************************************************************************
503 \subsection[SpecInstSigs-Rename2]{Functions for @AbstractTypeSigs@}
505 %************************************************************************
507 We don't make any effort to look for duplicate ``SPECIALIZE instance''
510 We do this by make \tr{cmp*} always return \tr{LT_}---then there's
511 nothing for \tr{sel*} to do!
515 :: ProtoNameSpecialisedInstanceSig -> ProtoNameSpecialisedInstanceSig -> TAG_
516 selSpecInstSigs :: ProtoNameSpecialisedInstanceSig
517 -> ProtoNameSpecialisedInstanceSig
518 -> Rn12M ProtoNameSpecialisedInstanceSig
520 cmpSpecInstSigs a b = LT_
521 selSpecInstSigs a b = panic "Rename2:selSpecInstSigs"
524 %************************************************************************
526 \subsection{Functions for SigDecls}
528 %************************************************************************
530 These \tr{*Sig} functions only operate on things from interfaces, so
531 we don't have to worry about user-pragmas and other such junk.
534 cmpSig :: ProtoNameSig -> ProtoNameSig -> TAG_
536 cmpSig (Sig n1 _ _ _) (Sig n2 _ _ _) = cmpProtoName n1 n2
539 cmpSig _ _ = case (panic "cmpSig (rename2)") of { s -> -- should never happen
542 selSig :: ProtoNameSig -> ProtoNameSig -> Rn12M ProtoNameSig
544 selSig s1@(Sig n1 ty pragmas1 locn1) s2@(Sig n2 _ pragmas2 locn2)
545 = selByBetterName "type signature"
548 (\ p -> Sig n1 ty p locn1) -- w/out its pragmas
553 chooser_Sig wout_prags g1 l1 s1@(Sig n1 ty1 _ _) g2 l2 s2@(Sig n2 ty2 _ _)
554 = case (cmpPolyType cmpProtoName ty1 ty2) of
556 recoverQuietlyRn12 NoGenPragmas (
557 selGenPragmas g1 l1 g2 l2
558 ) `thenRn12` \ new_prags ->
559 returnRn12 (wout_prags new_prags)
560 _ -> report_dup "signature" n1 l1 n2 l2 s1
563 %************************************************************************
565 \subsection{Help functions: selecting based on pragmas}
567 %************************************************************************
571 :: ProtoNameGenPragmas -> SrcLoc
572 -> ProtoNameGenPragmas -> SrcLoc
573 -> Rn12M ProtoNameGenPragmas
575 selGenPragmas NoGenPragmas _ b _ = returnRn12 b
576 selGenPragmas a _ NoGenPragmas _ = returnRn12 a
578 selGenPragmas g1@(GenPragmas arity1 upd1 def1 strict1 unfold1 specs1) locn1
579 g2@(GenPragmas arity2 upd2 def2 strict2 unfold2 specs2) locn2
581 = sel_arity arity1 arity2 `thenRn12` \ arity ->
582 sel_upd upd1 upd2 `thenRn12` \ upd ->
583 sel_def def1 def2 `thenRn12` \ def ->
584 sel_strict strict1 strict2 `thenRn12` \ strict ->
585 sel_unfold unfold1 unfold2 `thenRn12` \ unfold ->
586 sel_specs specs1 specs2 `thenRn12` \ specs ->
587 returnRn12 (GenPragmas arity upd def strict unfold specs)
589 sel_arity Nothing Nothing = returnRn12 Nothing
590 sel_arity a@(Just a1) (Just a2) = if a1 == a2
592 else pRAGMA_ERROR "arity pragmas" a
593 sel_arity a _ = pRAGMA_ERROR "arity pragmas" a
596 sel_upd Nothing Nothing = returnRn12 Nothing
597 sel_upd a@(Just u1) (Just u2) = if u1 == u2
599 else pRAGMA_ERROR "update pragmas" a
600 sel_upd a _ = pRAGMA_ERROR "update pragmas" a
603 sel_def Don'tDeforest Don'tDeforest = returnRn12 Don'tDeforest
604 sel_def DoDeforest DoDeforest = returnRn12 DoDeforest
605 sel_def a _ = pRAGMA_ERROR "deforest pragmas" a
608 sel_unfold NoImpUnfolding b = returnRn12 b
609 sel_unfold a NoImpUnfolding = returnRn12 a
611 sel_unfold a@(ImpUnfolding _ c1) (ImpUnfolding _ c2)
612 = if c1 `eqUfExpr` c2 -- very paranoid (and rightly so)
614 else pprTrace "mismatched unfoldings:\n" (ppAbove (ppr PprDebug c1) (ppr PprDebug c2)) (
615 returnRn12 NoImpUnfolding
618 sel_unfold a@(ImpMagicUnfolding b) (ImpMagicUnfolding c)
619 = if b == c then returnRn12 a else pRAGMA_ERROR "magic unfolding" a
621 sel_unfold a _ = pRAGMA_ERROR "unfolding pragmas" a
624 sel_strict NoImpStrictness NoImpStrictness = returnRn12 NoImpStrictness
626 sel_strict a@(ImpStrictness b1 i1 g1) (ImpStrictness b2 i2 g2)
627 = if b1 /= b2 || i1 /= i2
628 then pRAGMA_ERROR "strictness pragmas" a
629 else recoverQuietlyRn12 NoGenPragmas (
630 selGenPragmas g1 locn1 g2 locn2
631 ) `thenRn12` \ wrkr_prags ->
632 returnRn12 (ImpStrictness b1 i1 wrkr_prags)
634 sel_strict a _ = pRAGMA_ERROR "strictness pragmas" a
637 sel_specs specs1 specs2
638 = selSpecialisations specs1 locn1 specs2 locn2
643 :: [(ProtoName, ProtoNameGenPragmas)] -> SrcLoc
644 -> [(ProtoName, ProtoNameGenPragmas)] -> SrcLoc
645 -> Rn12M [(ProtoName, ProtoNameGenPragmas)]
647 selNamePragmaPairs [] _ [] _ = returnRn12 []
648 selNamePragmaPairs [] _ bs _ = returnRn12 bs
649 selNamePragmaPairs as _ [] _ = returnRn12 as
651 selNamePragmaPairs ((name1, prags1) : pairs1) loc1
652 ((name2, prags2) : pairs2) loc2
654 = if not (name1 `eqProtoName` name2) then
655 -- msg of any kind??? ToDo
656 pRAGMA_ERROR "named pragmas" pairs1
658 selGenPragmas prags1 loc1 prags2 loc2 `thenRn12` \ new_prags ->
659 selNamePragmaPairs pairs1 loc1 pairs2 loc2 `thenRn12` \ rest ->
660 returnRn12 ( (name1, new_prags) : rest )
663 For specialisations we merge the lists from each Sig. This allows the user to
664 declare specialised prelude functions in their own PreludeSpec module.
668 :: [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)] -> SrcLoc
669 -> [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)] -> SrcLoc
670 -> Rn12M [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)]
672 selSpecialisations [] _ [] _ = returnRn12 []
673 selSpecialisations [] _ bs _ = returnRn12 bs -- arguable ... ToDo?
674 selSpecialisations as _ [] _ = returnRn12 as -- ditto
676 selSpecialisations all_specs1@((spec1, dicts1, prags1) : rest_specs1) loc1
677 all_specs2@((spec2, dicts2, prags2) : rest_specs2) loc2
679 = case (cmp_spec spec1 spec2) of
680 LT_ -> selSpecialisations rest_specs1 loc1 all_specs2 loc2
682 returnRn12 ( (spec1, dicts1, prags1) : rest )
684 EQ_ -> ASSERT(dicts1 == dicts2)
685 recoverQuietlyRn12 NoGenPragmas (
686 selGenPragmas prags1 loc1 prags2 loc2
687 ) `thenRn12` \ new_prags ->
688 selSpecialisations rest_specs1 loc1 rest_specs2 loc2
690 returnRn12 ( (spec1, dicts1, new_prags) : rest )
692 GT_ -> selSpecialisations all_specs1 loc1 rest_specs2 loc2
694 returnRn12 ( (spec2, dicts2, prags2) : rest )
697 cmp_spec (Nothing:xs) (Nothing:ys) = cmp_spec xs ys
698 cmp_spec (Just t1:xs) (Just t2:ys) = case cmpMonoType cmpProtoName t1 t2 of
699 EQ_ -> cmp_spec xs ys
701 cmp_spec (Nothing:xs) (Just t2:ys) = LT_
702 cmp_spec (Just t1:xs) (Nothing:ys) = GT_
705 %************************************************************************
707 \subsection{Help functions: @uniquefy@ and @selByBetterName@}
709 %************************************************************************
712 uniquefy :: FAST_STRING -- Module name
713 -> (a -> a -> TAG_) -- Comparison function
714 -> (a -> a -> Rn12M a) -- Selection function
715 -> [a] -- Things to be processed
716 -> Rn12M [a] -- Processed things
718 uniquefy mod cmp sel things
719 = mapRn12 (check_group_consistency sel) grouped_things
721 grouped_things = equivClasses cmp things
723 check_group_consistency :: (a -> a -> Rn12M a) -- Selection function
724 -> [a] -- things to be compared
727 check_group_consistency sel [] = panic "Rename2: runs produced an empty list"
728 check_group_consistency sel (thing:things) = foldrRn12 sel thing things
731 @selByBetterName@: There are two ways one thing can have a ``better
734 First: Something with an @Unk@ name is declared in this module, so we
735 keep that, rather than something from an interface (with an @Imp@
738 Second: If we have two non-@Unk@ names, but one ``informant module''
739 is also the {\em original} module for the entity, then we choose that
740 one. I.e., if one interface says, ``I am the module that created this
741 thing'' then we believe it and take that one.
743 If we can't figure out which one to choose by the names, we use the
744 info provided to select based on the pragmas.
746 LATER: but surely we have to worry about different-by-original-name
747 things which are same-by-local-name things---these should be reported
751 selByBetterName :: String -- class/datatype/synonym (for error msg)
753 -- 1st/2nd comparee name/pragmas + their things
754 -> ProtoName -> pragmas -> SrcLoc -> thing
755 -> ProtoName -> pragmas -> SrcLoc -> thing
757 -- a thing without its pragmas
758 -> (pragmas -> thing)
760 -- choose-by-pragma function
761 -> ((pragmas -> thing) -- thing minus its pragmas
762 -> pragmas -> SrcLoc -> thing -- comparee 1
763 -> pragmas -> SrcLoc -> thing -- comparee 2
764 -> Rn12M thing ) -- thing w/ its new pragmas
766 -> Rn12M thing -- selected thing
768 selByBetterName dup_msg
769 pn1 pragmas1 locn1 thing1
770 pn2 pragmas2 locn2 thing2
773 = getModuleNameRn12 `thenRn12` \ mod_name ->
775 choose_thing1 = chk_eq (returnRn12 thing1)
776 choose_thing2 = chk_eq (returnRn12 thing2)
777 check_n_choose = chk_eq (chooser thing_wout_pragmas
778 pragmas1 locn1 thing1
779 pragmas2 locn2 thing2)
781 dup_error = report_dup dup_msg pn1 locn1 pn2 locn2 thing1
786 _ -> if orig_modules_clash mod_name pn2
790 Prel _ -> case pn2 of
791 Unk _ -> if orig_modules_clash mod_name pn1
796 Imp om1 _ im1 _ -> -- we're gonna check `informant module' info...
798 Unk _ -> if orig_modules_clash mod_name pn1
801 Prel _ -> check_n_choose
804 is_elem = isIn "selByBetterName"
806 name1_claims_orig = om1 `is_elem` im1 && not (_NULL_ om1)
807 name2_claims_orig = om2 `is_elem` im2 && not (_NULL_ om2)
810 then if name2_claims_orig then check_n_choose else choose_thing1
811 else if name2_claims_orig then choose_thing2 else check_n_choose
814 = if not (eqProtoName pn1 pn2) && eqByLocalName pn1 pn2
815 then report_dup dup_msg pn1 locn1 pn2 locn2 thing1
818 orig_modules_clash this_module pn
819 = case (getOrigName pn) of { (that_module, _) ->
820 not (this_module == that_module) }
822 report_dup dup_msg pn1 locn1 pn2 locn2 thing
823 = addErrRn12 err_msg `thenRn12` \ _ ->
826 err_msg = dupNamesErr dup_msg [(pn1,locn1), (pn2,locn2)]
828 pRAGMA_ERROR :: String -> a -> Rn12M a
830 = addErrRn12 (\ sty -> ppStr ("PRAGMA ERROR:"++msg)) `thenRn12` \ _ ->