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 ( 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 eq_data_specs [] [] = True
251 eq_data_specs (spec1:specs1) (spec2:specs2)
252 = eq_spec spec1 spec2 && eq_data_specs specs1 specs2
253 eq_data_specs _ _ = False
256 = ppBesides [ppStr "_SPECIALISE_ ", pp_the_list [
257 ppCat [ppLbrack, ppInterleave ppComma (map pp_maybe ty_maybes), ppRbrack]
258 | ty_maybes <- specs ]]
261 pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
263 pp_maybe Nothing = pp_NONE
264 pp_maybe (Just ty) = pprParendMonoType PprDebug ty
266 pp_NONE = ppStr "_N_"
269 Sort of similar deal on synonyms: this is the time to check that the
270 expansions are really the same; otherwise, we use the pragmas.
273 chooser_TySynonym wout pragmas1 locn1 ts1@(TySynonym name1 _ expand1 _ _)
274 pragmas2 locn2 ts2@(TySynonym name2 _ expand2 _ _)
275 = if not (eqMonoType expand1 expand2) then
276 report_dup "type synonym" name1 locn1 name2 locn2 ts1
278 sub_chooser pragmas1 pragmas2
280 sub_chooser NoTypePragmas b = returnRn12 (wout b)
281 sub_chooser a NoTypePragmas = returnRn12 (wout a)
282 sub_chooser a _ = returnRn12 (wout a) -- same, just pick one
285 %************************************************************************
287 \subsection[DataTypeSigs-Rename2]{Functions for @DataTypeSigs@}
289 %************************************************************************
292 cmpTySigs :: ProtoNameDataTypeSig -> ProtoNameDataTypeSig -> TAG_
294 cmpTySigs (AbstractTypeSig n1 _) (AbstractTypeSig n2 _)
296 cmpTySigs (SpecDataSig n1 ty1 _) (SpecDataSig n2 ty2 _)
297 = case cmpProtoName n1 n2 of
298 EQ_ -> LT_ -- multiple SPECIALIZE data pragmas allowed
300 cmpTySigs (AbstractTypeSig n1 _) (SpecDataSig n2 _ _)
302 cmpTySigs (SpecDataSig n1 _ _) (AbstractTypeSig n2 _)
305 selTySigs :: ProtoNameDataTypeSig
306 -> ProtoNameDataTypeSig
307 -> Rn12M ProtoNameDataTypeSig
309 selTySigs s1@(AbstractTypeSig n1 locn1) s2@(AbstractTypeSig n2 locn2)
310 = selByBetterName "ABSTRACT user-pragma"
315 bottom = panic "Rename2:selTySigs:AbstractTypeSig"
317 selTySigs s1@(SpecDataSig n1 ty1 locn1) s2@(SpecDataSig n2 ty2 locn2)
318 = selByBetterName "ABSTRACT user-pragma"
323 bottom = panic "Rename2:selTySigs:SpecDataSig"
326 %************************************************************************
328 \subsection[ClassDecl-Rename2]{Functions for @ClassDecls@}
330 %************************************************************************
333 cmpClassDecl :: ProtoNameClassDecl -> ProtoNameClassDecl -> TAG_
335 cmpClassDecl (ClassDecl _ n1 _ _ _ _ _) (ClassDecl _ n2 _ _ _ _ _)
338 selClass :: ProtoNameClassDecl -> ProtoNameClassDecl
339 -> Rn12M ProtoNameClassDecl
341 selClass cd1@(ClassDecl ctxt n1 tv sigs bs pragmas1 locn1)
342 cd2@(ClassDecl _ n2 _ _ _ pragmas2 locn2)
343 = selByBetterName "class"
344 n1 pragmas1 locn1 cd1
345 n2 pragmas2 locn2 cd2
346 (\ p -> ClassDecl ctxt n1 tv sigs bs p locn1)
351 chooser_Class wout NoClassPragmas _ _ b _ _ = returnRn12 (wout b)
352 chooser_Class wout a _ _ NoClassPragmas _ _ = returnRn12 (wout a)
354 chooser_Class wout sd1@(SuperDictPragmas gs1) l1 _ sd2@(SuperDictPragmas gs2) l2 _
355 = if length gs1 /= length gs2 then -- urgh
356 returnRn12 (wout NoClassPragmas)
358 recoverQuietlyRn12 [{-no gen prags-}] (
359 zipWithRn12 choose_prag gs1 gs2
360 ) `thenRn12` \ new_gprags ->
362 if null new_gprags then
363 pprTrace "tossed all SuperDictPragmas (rename2):"
364 (ppAbove (ppr PprDebug sd1) (ppr PprDebug sd2))
367 SuperDictPragmas new_gprags
370 choose_prag g1 g2 = selGenPragmas g1 l1 g2 l2
373 %************************************************************************
375 \subsection[InstDecls-Rename2]{Functions for @InstDecls@}
377 %************************************************************************
380 cmpInst :: ProtoNameInstDecl -> ProtoNameInstDecl -> TAG_
382 cmpInst (InstDecl _ c1 ty1 _ _ _ _ _ _ _) (InstDecl _ c2 ty2 _ _ _ _ _ _ _)
383 = case cmpProtoName c1 c2 of
384 EQ_ -> cmpInstanceTypes ty1 ty2
388 Select the instance declaration from the module (rather than an
389 interface), if it exists.
392 selInst :: ProtoNameInstDecl -> ProtoNameInstDecl
393 -> Rn12M ProtoNameInstDecl
395 selInst i1@(InstDecl ctxt c ty bs from_here1 orig_mod1 infor_mod1 uprags pragmas1 locn1)
396 i2@(InstDecl _ _ _ _ from_here2 orig_mod2 infor_mod2 _ pragmas2 locn2)
398 have_orig_mod1 = not (_NULL_ orig_mod1)
399 have_orig_mod2 = not (_NULL_ orig_mod2)
401 choose_no1 = returnRn12 i1
402 choose_no2 = returnRn12 i2
404 -- generally: try to keep the locally-defined instance decl
406 if from_here1 && from_here2 then
407 -- If they are both from this module, don't throw either away,
408 -- otherwise we silently discard erroneous duplicates
409 trace ("selInst: duplicate instance in this module (ToDo: msg!)")
412 else if from_here1 then
413 if ( have_orig_mod1 && have_orig_mod2 && orig_mod1 /= orig_mod2 ) then
414 trace ("selInst: instance in this module also defined somewhere else! (ToDo: msg!)")
419 else if from_here2 then
420 if ( have_orig_mod1 && have_orig_mod2 && orig_mod1 /= orig_mod2 ) then
421 trace ("selInst: instance in this module also defined somewhere else! (ToDo: msg!)")
426 else -- it's definitely an imported instance;
427 -- first, a quick sanity check...
428 if ( have_orig_mod1 && have_orig_mod2 && orig_mod1 /= orig_mod2 ) then
429 trace ("selInst: `same' instances coming in from two modules! (ToDo: msg!)")
430 choose_no2 -- arbitrary
432 -- now we *cheat*: so we can use the "informing module" stuff
433 -- in "selByBetterName", we *make up* some ProtoNames for
434 -- these instance decls
436 ii = SLIT("!*INSTANCE*!")
437 n1 = Imp orig_mod1 ii [infor_mod1] ii
438 n2 = Imp orig_mod2 ii [infor_mod2] ii
440 selByBetterName "instance"
443 (\ p -> InstDecl ctxt c ty bs from_here1 orig_mod1 infor_mod1
449 chooser_Inst wout iprags1 loc1 i1 iprags2 loc2 i2
450 = chk_pragmas iprags1 iprags2
453 chk_pragmas NoInstancePragmas b = returnRn12 (wout b)
454 chk_pragmas a NoInstancePragmas = returnRn12 (wout a)
456 -- SimpleInstance pragmas meet: choose by GenPragmas
457 chk_pragmas (SimpleInstancePragma gprags1) (SimpleInstancePragma gprags2)
458 = recoverQuietlyRn12 NoGenPragmas (
459 selGenPragmas gprags1 loc1 gprags2 loc2
460 ) `thenRn12` \ new_prags ->
463 NoGenPragmas -> NoInstancePragmas -- bottled out
464 _ -> SimpleInstancePragma new_prags
467 -- SimpleInstance pragma meets anything else... take the "else"
468 chk_pragmas (SimpleInstancePragma _) b = returnRn12 (wout b)
469 chk_pragmas a (SimpleInstancePragma _) = returnRn12 (wout a)
471 chk_pragmas (ConstantInstancePragma gp1 prs1) (ConstantInstancePragma gp2 prs2)
472 = recoverQuietlyRn12 NoGenPragmas (
473 selGenPragmas gp1 loc1 gp2 loc2
474 ) `thenRn12` \ dfun_prags ->
476 recoverQuietlyRn12 [] (
477 selNamePragmaPairs prs1 loc1 prs2 loc2
478 ) `thenRn12` \ new_pairs ->
481 if null new_pairs then -- bottled out
483 NoGenPragmas -> NoInstancePragmas -- doubly bottled out
484 _ -> SimpleInstancePragma dfun_prags
486 ConstantInstancePragma dfun_prags new_pairs
489 -- SpecialisedInstancePragmas: choose by gens, then specialisations
490 chk_pragmas a@(SpecialisedInstancePragma _ _) (SpecialisedInstancePragma _ _)
491 = trace "not checking two SpecialisedInstancePragma pragmas!" (returnRn12 (wout a))
493 chk_pragmas other1 other2 -- oops, bad mismatch
494 = pRAGMA_ERROR "instance pragmas" (wout other1) -- ToDo: msg
497 %************************************************************************
499 \subsection[SpecInstSigs-Rename2]{Functions for @AbstractTypeSigs@}
501 %************************************************************************
503 We don't make any effort to look for duplicate ``SPECIALIZE instance''
506 We do this by make \tr{cmp*} always return \tr{LT_}---then there's
507 nothing for \tr{sel*} to do!
511 :: ProtoNameSpecialisedInstanceSig -> ProtoNameSpecialisedInstanceSig -> TAG_
512 selSpecInstSigs :: ProtoNameSpecialisedInstanceSig
513 -> ProtoNameSpecialisedInstanceSig
514 -> Rn12M ProtoNameSpecialisedInstanceSig
516 cmpSpecInstSigs a b = LT_
517 selSpecInstSigs a b = panic "Rename2:selSpecInstSigs"
520 %************************************************************************
522 \subsection{Functions for SigDecls}
524 %************************************************************************
526 These \tr{*Sig} functions only operate on things from interfaces, so
527 we don't have to worry about user-pragmas and other such junk.
530 cmpSig :: ProtoNameSig -> ProtoNameSig -> TAG_
532 cmpSig (Sig n1 _ _ _) (Sig n2 _ _ _) = cmpProtoName n1 n2
535 cmpSig _ _ = case (panic "cmpSig (rename2)") of { s -> -- should never happen
538 selSig :: ProtoNameSig -> ProtoNameSig -> Rn12M ProtoNameSig
540 selSig s1@(Sig n1 ty pragmas1 locn1) s2@(Sig n2 _ pragmas2 locn2)
541 = selByBetterName "type signature"
544 (\ p -> Sig n1 ty p locn1) -- w/out its pragmas
549 chooser_Sig wout_prags g1 l1 s1@(Sig n1 ty1 _ _) g2 l2 s2@(Sig n2 ty2 _ _)
550 = case (cmpPolyType cmpProtoName ty1 ty2) of
552 recoverQuietlyRn12 NoGenPragmas (
553 selGenPragmas g1 l1 g2 l2
554 ) `thenRn12` \ new_prags ->
555 returnRn12 (wout_prags new_prags)
556 _ -> report_dup "signature" n1 l1 n2 l2 s1
559 %************************************************************************
561 \subsection{Help functions: selecting based on pragmas}
563 %************************************************************************
567 :: ProtoNameGenPragmas -> SrcLoc
568 -> ProtoNameGenPragmas -> SrcLoc
569 -> Rn12M ProtoNameGenPragmas
571 selGenPragmas NoGenPragmas _ b _ = returnRn12 b
572 selGenPragmas a _ NoGenPragmas _ = returnRn12 a
574 selGenPragmas g1@(GenPragmas arity1 upd1 def1 strict1 unfold1 specs1) locn1
575 g2@(GenPragmas arity2 upd2 def2 strict2 unfold2 specs2) locn2
577 = sel_arity arity1 arity2 `thenRn12` \ arity ->
578 sel_upd upd1 upd2 `thenRn12` \ upd ->
579 sel_def def1 def2 `thenRn12` \ def ->
580 sel_strict strict1 strict2 `thenRn12` \ strict ->
581 sel_unfold unfold1 unfold2 `thenRn12` \ unfold ->
582 sel_specs specs1 specs2 `thenRn12` \ specs ->
583 returnRn12 (GenPragmas arity upd def strict unfold specs)
585 sel_arity Nothing Nothing = returnRn12 Nothing
586 sel_arity a@(Just a1) (Just a2) = if a1 == a2
588 else pRAGMA_ERROR "arity pragmas" a
589 sel_arity a _ = pRAGMA_ERROR "arity pragmas" a
592 sel_upd Nothing Nothing = returnRn12 Nothing
593 sel_upd a@(Just u1) (Just u2) = if u1 == u2
595 else pRAGMA_ERROR "update pragmas" a
596 sel_upd a _ = pRAGMA_ERROR "update pragmas" a
599 sel_def Don'tDeforest Don'tDeforest = returnRn12 Don'tDeforest
600 sel_def DoDeforest DoDeforest = returnRn12 DoDeforest
601 sel_def a _ = pRAGMA_ERROR "deforest pragmas" a
604 sel_unfold NoImpUnfolding b = returnRn12 b
605 sel_unfold a NoImpUnfolding = returnRn12 a
607 sel_unfold a@(ImpUnfolding _ c1) (ImpUnfolding _ c2)
608 = if c1 `eqUfExpr` c2 -- very paranoid (and rightly so)
610 else pprTrace "mismatched unfoldings:\n" (ppAbove (ppr PprDebug c1) (ppr PprDebug c2)) (
611 returnRn12 NoImpUnfolding
614 sel_unfold a@(ImpMagicUnfolding b) (ImpMagicUnfolding c)
615 = if b == c then returnRn12 a else pRAGMA_ERROR "magic unfolding" a
617 sel_unfold a _ = pRAGMA_ERROR "unfolding pragmas" a
620 sel_strict NoImpStrictness NoImpStrictness = returnRn12 NoImpStrictness
622 sel_strict a@(ImpStrictness b1 i1 g1) (ImpStrictness b2 i2 g2)
623 = if b1 /= b2 || i1 /= i2
624 then pRAGMA_ERROR "strictness pragmas" a
625 else recoverQuietlyRn12 NoGenPragmas (
626 selGenPragmas g1 locn1 g2 locn2
627 ) `thenRn12` \ wrkr_prags ->
628 returnRn12 (ImpStrictness b1 i1 wrkr_prags)
630 sel_strict a _ = pRAGMA_ERROR "strictness pragmas" a
633 sel_specs specs1 specs2
634 = selSpecialisations specs1 locn1 specs2 locn2
639 :: [(ProtoName, ProtoNameGenPragmas)] -> SrcLoc
640 -> [(ProtoName, ProtoNameGenPragmas)] -> SrcLoc
641 -> Rn12M [(ProtoName, ProtoNameGenPragmas)]
643 selNamePragmaPairs [] _ [] _ = returnRn12 []
644 selNamePragmaPairs [] _ bs _ = returnRn12 bs
645 selNamePragmaPairs as _ [] _ = returnRn12 as
647 selNamePragmaPairs ((name1, prags1) : pairs1) loc1
648 ((name2, prags2) : pairs2) loc2
650 = if not (name1 `eqProtoName` name2) then
651 -- msg of any kind??? ToDo
652 pRAGMA_ERROR "named pragmas" pairs1
654 selGenPragmas prags1 loc1 prags2 loc2 `thenRn12` \ new_prags ->
655 selNamePragmaPairs pairs1 loc1 pairs2 loc2 `thenRn12` \ rest ->
656 returnRn12 ( (name1, new_prags) : rest )
661 :: [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)] -> SrcLoc
662 -> [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)] -> SrcLoc
663 -> Rn12M [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)]
665 selSpecialisations [] _ [] _ = returnRn12 []
666 selSpecialisations [] _ bs _ = returnRn12 bs -- arguable ... ToDo?
667 selSpecialisations as _ [] _ = returnRn12 as -- ditto
669 selSpecialisations ((spec1, dicts1, prags1) : specs1) loc1
670 ((spec2, dicts2, prags2) : specs2) loc2
672 = if not (eq_spec spec1 spec2) || dicts1 /= dicts2 then
673 -- msg of any kind??? ToDo
674 pRAGMA_ERROR "specialisation pragmas" specs1
676 recoverQuietlyRn12 NoGenPragmas (
677 selGenPragmas prags1 loc1 prags2 loc2
678 ) `thenRn12` \ new_prags ->
679 selSpecialisations specs1 loc1 specs2 loc2
681 returnRn12 ( (spec1, dicts1, new_prags) : rest )
684 eq_spec (Nothing:xs) (Nothing:ys) = eq_spec xs ys
685 eq_spec (Just t1:xs) (Just t2:ys) = eqMonoType t1 t2 && eq_spec xs ys
689 %************************************************************************
691 \subsection{Help functions: @uniquefy@ and @selByBetterName@}
693 %************************************************************************
696 uniquefy :: FAST_STRING -- Module name
697 -> (a -> a -> TAG_) -- Comparison function
698 -> (a -> a -> Rn12M a) -- Selection function
699 -> [a] -- Things to be processed
700 -> Rn12M [a] -- Processed things
702 uniquefy mod cmp sel things
703 = mapRn12 (check_group_consistency sel) grouped_things
705 grouped_things = equivClasses cmp things
707 check_group_consistency :: (a -> a -> Rn12M a) -- Selection function
708 -> [a] -- things to be compared
711 check_group_consistency sel [] = panic "Rename2: runs produced an empty list"
712 check_group_consistency sel (thing:things) = foldrRn12 sel thing things
715 @selByBetterName@: There are two ways one thing can have a ``better
718 First: Something with an @Unk@ name is declared in this module, so we
719 keep that, rather than something from an interface (with an @Imp@
722 Second: If we have two non-@Unk@ names, but one ``informant module''
723 is also the {\em original} module for the entity, then we choose that
724 one. I.e., if one interface says, ``I am the module that created this
725 thing'' then we believe it and take that one.
727 If we can't figure out which one to choose by the names, we use the
728 info provided to select based on the pragmas.
730 LATER: but surely we have to worry about different-by-original-name
731 things which are same-by-local-name things---these should be reported
735 selByBetterName :: String -- class/datatype/synonym (for error msg)
737 -- 1st/2nd comparee name/pragmas + their things
738 -> ProtoName -> pragmas -> SrcLoc -> thing
739 -> ProtoName -> pragmas -> SrcLoc -> thing
741 -- a thing without its pragmas
742 -> (pragmas -> thing)
744 -- choose-by-pragma function
745 -> ((pragmas -> thing) -- thing minus its pragmas
746 -> pragmas -> SrcLoc -> thing -- comparee 1
747 -> pragmas -> SrcLoc -> thing -- comparee 2
748 -> Rn12M thing ) -- thing w/ its new pragmas
750 -> Rn12M thing -- selected thing
752 selByBetterName dup_msg
753 pn1 pragmas1 locn1 thing1
754 pn2 pragmas2 locn2 thing2
757 = getModuleNameRn12 `thenRn12` \ mod_name ->
759 choose_thing1 = chk_eq (returnRn12 thing1)
760 choose_thing2 = chk_eq (returnRn12 thing2)
761 check_n_choose = chk_eq (chooser thing_wout_pragmas
762 pragmas1 locn1 thing1
763 pragmas2 locn2 thing2)
765 dup_error = report_dup dup_msg pn1 locn1 pn2 locn2 thing1
770 _ -> if orig_modules_clash mod_name pn2
774 Prel _ -> case pn2 of
775 Unk _ -> if orig_modules_clash mod_name pn1
780 Imp om1 _ im1 _ -> -- we're gonna check `informant module' info...
782 Unk _ -> if orig_modules_clash mod_name pn1
785 Prel _ -> check_n_choose
788 is_elem = isIn "selByBetterName"
790 name1_claims_orig = om1 `is_elem` im1 && not (_NULL_ om1)
791 name2_claims_orig = om2 `is_elem` im2 && not (_NULL_ om2)
794 then if name2_claims_orig then check_n_choose else choose_thing1
795 else if name2_claims_orig then choose_thing2 else check_n_choose
798 = if not (eqProtoName pn1 pn2) && eqByLocalName pn1 pn2
799 then report_dup dup_msg pn1 locn1 pn2 locn2 thing1
802 orig_modules_clash this_module pn
803 = case (getOrigName pn) of { (that_module, _) ->
804 not (this_module == that_module) }
806 report_dup dup_msg pn1 locn1 pn2 locn2 thing
807 = addErrRn12 err_msg `thenRn12` \ _ ->
810 err_msg = dupNamesErr dup_msg [(pn1,locn1), (pn2,locn2)]
812 pRAGMA_ERROR :: String -> a -> Rn12M a
814 = addErrRn12 (\ sty -> ppStr ("PRAGMA ERROR:"++msg)) `thenRn12` \ _ ->