2 % (c) The GRASP Project, Glasgow University, 1992-1996
4 \section[RnPass2]{Second renaming pass: boil down to non-duplicated info}
7 #include "HsVersions.h"
24 import IdInfo ( DeforestInfo(..), Demand{-instances-}, UpdateInfo{-instance-} )
25 import Outputable ( Outputable(..){-instances-} )
26 import PprStyle ( PprStyle(..) )
27 import Pretty -- quite a bit of it
28 import ProtoName ( cmpProtoName, eqProtoName, eqByLocalName,
29 elemProtoNames, elemByLocalNames,
32 import RnUtils ( dupNamesErr )
33 import SrcLoc ( mkUnknownSrcLoc, SrcLoc{-instances-} )
34 import Util ( isIn, equivClasses,
35 panic, panic#, pprTrace, assertPanic
39 This pass removes duplicate declarations. Duplicates can arise when
40 two imported interface have a signature (or whatever) for the same
41 thing. We check that the two are consistent and then drop one.
43 For preference, if one is declared in this module and the other is
44 imported, we keep the former; in the case of an instance decl or type
45 decl, the local version has a lot more information which we must not
48 Similarly, if one has interesting pragmas and one has not, we keep the
51 The notion of ``duplicate'' includes an imported signature and a
52 binding in this module. In this case, the signature is discarded.
53 See note below about how this should be improved.
55 ToDo: There are still known cases in which we blithely consider two
56 declarations to be ``duplicates'' and we then select one of them, {\em
57 without} actually checking that they contain the same information!
58 [WDP 93/8/16] [Improved, at least WDP 93/08/26]
61 rnModule2 :: ProtoNameHsModule -> Rn12M ProtoNameHsModule
63 rnModule2 (HsModule mod_name exports imports fixes
64 ty_decls absty_sigs class_decls inst_decls specinst_sigs
65 defaults binds int_sigs src_loc)
67 = uniquefy mod_name cmpFix selFix fixes
70 uniquefy mod_name cmpTys selTys ty_decls
71 `thenRn12` \ ty_decls ->
73 uniquefy mod_name cmpTySigs selTySigs absty_sigs
74 `thenRn12` \ absty_sigs ->
76 uniquefy mod_name cmpClassDecl selClass class_decls
77 `thenRn12` \ class_decls ->
79 uniquefy mod_name cmpInst selInst inst_decls
80 `thenRn12` \ inst_decls ->
82 uniquefy mod_name cmpSpecInstSigs selSpecInstSigs specinst_sigs
83 `thenRn12` \ specinst_sigs ->
85 -- From the imported signatures discard any which are for
86 -- variables bound in this module.
87 -- But, be wary of those that *clash* with those for this
89 -- Note that we want to do this properly later (ToDo) because imported
90 -- signatures may differ from those declared in the module itself.
92 rm_sigs_for_here mod_name int_sigs
93 `thenRn12` \ non_here_int_sigs ->
95 uniquefy mod_name cmpSig selSig non_here_int_sigs
96 `thenRn12` \ int_sigs ->
99 exports -- export and import lists are passed along
100 imports -- for checking in RnPass3; no other reason
112 top_level_binders = collectTopLevelBinders binds
114 rm_sigs_for_here :: FAST_STRING -> [ProtoNameSig] -> Rn12M [ProtoNameSig]
115 -- NB: operates only on interface signatures, so don't
116 -- need to worry about user-pragmas, etc.
118 rm_sigs_for_here mod_name [] = returnRn12 []
120 rm_sigs_for_here mod_name (sig@(Sig name _ _ src_loc) : more_sigs)
121 = rm_sigs_for_here mod_name more_sigs `thenRn12` \ rest_sigs ->
123 if not (name `elemByLocalNames` top_level_binders) then -- no name clash...
124 returnRn12 (sig : rest_sigs)
126 else -- name clash...
127 if name `elemProtoNames` top_level_binders
128 && name_for_this_module name then
129 -- the very same thing; just drop it
132 -- a different thing with the same name (due to renaming?)
133 -- ToDo: locations need improving
134 report_dup "(renamed?) variable"
135 name src_loc name mkUnknownSrcLoc
138 name_for_this_module (Imp m _ _ _) = m == mod_name
139 name_for_this_module other = True
142 %************************************************************************
144 \subsection[FixityDecls-RnPass2]{Functions for @FixityDecls@}
146 %************************************************************************
149 cmpFix :: ProtoNameFixityDecl -> ProtoNameFixityDecl -> TAG_
151 cmpFix (InfixL n1 i1) (InfixL n2 i2) = n1 `cmpProtoName` n2
152 cmpFix (InfixL n1 i1) other = LT_
153 cmpFix (InfixR n1 i1) (InfixR n2 i2) = n1 `cmpProtoName` n2
154 cmpFix (InfixR n1 i1) (InfixN n2 i2) = LT_
155 cmpFix (InfixN n1 i1) (InfixN n2 i2) = n1 `cmpProtoName` n2
159 We are pretty un-fussy about which FixityDecl we keep.
162 selFix :: ProtoNameFixityDecl -> ProtoNameFixityDecl -> Rn12M ProtoNameFixityDecl
163 selFix f1 f2 = returnRn12 f1
166 %************************************************************************
168 \subsection[TyDecls-RnPass2]{Functions for @TyDecls@}
170 %************************************************************************
173 cmpTys :: ProtoNameTyDecl -> ProtoNameTyDecl -> TAG_
175 cmpTys (TyData _ n1 _ _ _ _ _) (TyData _ n2 _ _ _ _ _) = cmpProtoName n1 n2
176 cmpTys (TyNew _ n1 _ _ _ _ _) (TyNew _ n2 _ _ _ _ _) = cmpProtoName n1 n2
177 cmpTys (TySynonym n1 _ _ _) (TySynonym n2 _ _ _) = cmpProtoName n1 n2
182 if tag1 _LT_ tag2 then LT_ else GT_
184 tag (TyData _ _ _ _ _ _ _) = (ILIT(1) :: FAST_INT)
185 tag (TyNew _ _ _ _ _ _ _) = ILIT(2)
186 tag (TySynonym _ _ _ _) = ILIT(3)
190 selTys :: ProtoNameTyDecl -> ProtoNameTyDecl
191 -> Rn12M ProtoNameTyDecl
193 -- Note: we could check these more closely.
194 -- NB: It would be a mistake to cross-check derivings,
195 -- because we don't preserve those in interfaces.
197 selTys td1@(TyData c name1 tvs cons1 ds pragmas1 locn1)
198 td2@(TyData _ name2 _ cons2 _ pragmas2 locn2)
199 = selByBetterName "algebraic datatype"
200 name1 pragmas1 locn1 td1
201 name2 pragmas2 locn2 td2
202 (\ p -> TyData c name1 tvs cons1 ds p locn1)
205 selTys td1@(TyNew c name1 tvs con1 ds pragmas1 locn1)
206 td2@(TyNew _ name2 _ con2 _ pragmas2 locn2)
207 = selByBetterName "algebraic newtype"
208 name1 pragmas1 locn1 td1
209 name2 pragmas2 locn2 td2
210 (\ p -> TyNew c name1 tvs con1 ds p locn1)
213 selTys ts1@(TySynonym name1 tvs expand1 locn1)
214 ts2@(TySynonym name2 _ expand2 locn2)
215 = selByBetterName "type synonym"
216 name1 bottom locn1 ts1
217 name2 bottom locn2 ts2
218 (\ p -> TySynonym name1 tvs expand1 locn1)
221 bottom = panic "RnPass2:selTys:TySynonym"
224 If only one is ``abstract'' (no condecls), we take the other.
226 Next, we check that they don't have differing lists of data
227 constructors (what a disaster if those get through...); then we do a
228 similar thing using pragmatic info.
231 chooser_TyNew wout pragmas1 locn1 td1@(TyNew _ name1 _ con1 _ _ _)
232 pragmas2 locn2 td2@(TyNew _ name2 _ con2 _ _ _)
233 = panic "RnPass2:chooser_TyNew"
236 chooser_TyData wout pragmas1 locn1 td1@(TyData _ name1 _ cons1 _ _ _)
237 pragmas2 locn2 td2@(TyData _ name2 _ cons2 _ _ _)
239 td1_abstract = null cons1
240 td2_abstract = null cons2
242 choose_by_pragmas = sub_chooser pragmas1 pragmas2
244 if td1_abstract && td2_abstract then
247 else if td1_abstract then
250 else if td2_abstract then
253 else if not (eqConDecls cons1 cons2) then
254 report_dup "algebraic datatype (mismatched data constuctors)"
255 name1 locn1 name2 locn2 td1
257 sub_chooser pragmas1 pragmas2
259 sub_chooser (DataPragmas [] []) b = returnRn12 (wout b)
260 sub_chooser a (DataPragmas [] []) = returnRn12 (wout a)
261 sub_chooser a@(DataPragmas cons1 specs1) (DataPragmas cons2 specs2)
262 = if not (eqConDecls cons1 cons2) then
263 pprTrace "Mismatched info in DATA pragmas:\n"
264 (ppAbove (ppr PprDebug cons1) (ppr PprDebug cons2)) (
265 returnRn12 (wout (DataPragmas [] []))
267 else if not (eq_data_specs specs1 specs2) then
268 pprTrace "Mismatched specialisation info in DATA pragmas:\n"
269 (ppAbove (ppr_data_specs specs1) (ppr_data_specs specs2)) (
270 returnRn12 (wout (DataPragmas [] []))
273 returnRn12 (wout a) -- same, pick one
275 -- ToDo: Should we use selByBetterName ???
276 -- ToDo: Report errors properly and recover quietly ???
278 -- ToDo: Should we merge specialisations ???
280 eq_data_specs [] [] = True
281 eq_data_specs (spec1:specs1) (spec2:specs2)
282 = eq_spec spec1 spec2 && eq_data_specs specs1 specs2
283 eq_data_specs _ _ = False
285 eq_spec spec1 spec2 = case cmp_spec spec1 spec2 of { EQ_ -> True; _ -> False}
288 = ppBesides [ppStr "_SPECIALISE_ ", pp_the_list [
289 ppCat [ppLbrack, ppInterleave ppComma (map pp_maybe ty_maybes), ppRbrack]
290 | ty_maybes <- specs ]]
293 pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
295 pp_maybe Nothing = pp_NONE
296 pp_maybe (Just ty) = pprParendMonoType PprDebug ty
298 pp_NONE = ppStr "_N_"
301 Sort of similar deal on synonyms: this is the time to check that the
302 expansions are really the same; otherwise, we use the pragmas.
305 chooser_TySynonym wout _ locn1 ts1@(TySynonym name1 _ expand1 _)
306 _ locn2 ts2@(TySynonym name2 _ expand2 _)
307 = if not (eqMonoType expand1 expand2) then
308 report_dup "type synonym" name1 locn1 name2 locn2 ts1
310 returnRn12 ts1 -- same, just pick one
313 %************************************************************************
315 \subsection[SpecDataSigs-RnPass2]{Functions for @SpecDataSigs@}
317 %************************************************************************
320 cmpTySigs :: ProtoNameSpecDataSig -> ProtoNameSpecDataSig -> TAG_
322 cmpTySigs (SpecDataSig n1 ty1 _) (SpecDataSig n2 ty2 _)
323 = case cmpProtoName n1 n2 of
324 EQ_ -> LT_ -- multiple SPECIALIZE data pragmas allowed
327 selTySigs :: ProtoNameSpecDataSig
328 -> ProtoNameSpecDataSig
329 -> Rn12M ProtoNameSpecDataSig
331 selTySigs s1@(SpecDataSig n1 ty1 locn1) s2@(SpecDataSig n2 ty2 locn2)
332 = selByBetterName "SPECIALIZE data user-pragma"
337 bottom = panic "RnPass2:selTySigs:SpecDataSig"
340 %************************************************************************
342 \subsection[ClassDecl-RnPass2]{Functions for @ClassDecls@}
344 %************************************************************************
347 cmpClassDecl :: ProtoNameClassDecl -> ProtoNameClassDecl -> TAG_
349 cmpClassDecl (ClassDecl _ n1 _ _ _ _ _) (ClassDecl _ n2 _ _ _ _ _)
352 selClass :: ProtoNameClassDecl -> ProtoNameClassDecl
353 -> Rn12M ProtoNameClassDecl
355 selClass cd1@(ClassDecl ctxt n1 tv sigs bs pragmas1 locn1)
356 cd2@(ClassDecl _ n2 _ _ _ pragmas2 locn2)
357 = selByBetterName "class"
358 n1 pragmas1 locn1 cd1
359 n2 pragmas2 locn2 cd2
360 (\ p -> ClassDecl ctxt n1 tv sigs bs p locn1)
365 chooser_Class wout NoClassPragmas _ _ b _ _ = returnRn12 (wout b)
366 chooser_Class wout a _ _ NoClassPragmas _ _ = returnRn12 (wout a)
368 chooser_Class wout sd1@(SuperDictPragmas gs1) l1 _ sd2@(SuperDictPragmas gs2) l2 _
369 = if length gs1 /= length gs2 then -- urgh
370 returnRn12 (wout NoClassPragmas)
372 recoverQuietlyRn12 [{-no gen prags-}] (
373 zipWithRn12 choose_prag gs1 gs2
374 ) `thenRn12` \ new_gprags ->
376 if null new_gprags then
377 pprTrace "tossed all SuperDictPragmas (rename2):"
378 (ppAbove (ppr PprDebug sd1) (ppr PprDebug sd2))
381 SuperDictPragmas new_gprags
384 choose_prag g1 g2 = selGenPragmas g1 l1 g2 l2
387 %************************************************************************
389 \subsection[InstDecls-RnPass2]{Functions for @InstDecls@}
391 %************************************************************************
394 cmpInst :: ProtoNameInstDecl -> ProtoNameInstDecl -> TAG_
396 cmpInst (InstDecl c1 ty1 _ _ _ _ _ _) (InstDecl c2 ty2 _ _ _ _ _ _)
397 = case cmpProtoName c1 c2 of
398 EQ_ -> cmpInstanceTypes ty1 ty2
402 Select the instance declaration from the module (rather than an
403 interface), if it exists.
406 selInst :: ProtoNameInstDecl -> ProtoNameInstDecl
407 -> Rn12M ProtoNameInstDecl
409 selInst i1@(InstDecl c ty bs from_here1 orig_mod1 uprags pragmas1 locn1)
410 i2@(InstDecl _ _ _ from_here2 orig_mod2 _ pragmas2 locn2)
412 have_orig_mod1 = not (_NULL_ orig_mod1)
413 have_orig_mod2 = not (_NULL_ orig_mod2)
415 choose_no1 = returnRn12 i1
416 choose_no2 = returnRn12 i2
418 -- generally: try to keep the locally-defined instance decl
420 if from_here1 && from_here2 then
421 -- If they are both from this module, don't throw either away,
422 -- otherwise we silently discard erroneous duplicates
423 trace ("selInst: duplicate instance in this module (ToDo: msg!)")
426 else if from_here1 then
427 if ( have_orig_mod1 && have_orig_mod2 && orig_mod1 /= orig_mod2 ) then
428 trace ("selInst: instance in this module also defined somewhere else! (ToDo: msg!)")
433 else if from_here2 then
434 if ( have_orig_mod1 && have_orig_mod2 && orig_mod1 /= orig_mod2 ) then
435 trace ("selInst: instance in this module also defined somewhere else! (ToDo: msg!)")
440 else -- it's definitely an imported instance;
441 -- first, a quick sanity check...
442 if ( have_orig_mod1 && have_orig_mod2 && orig_mod1 /= orig_mod2 ) then
443 trace ("selInst: `same' instances coming in from two modules! (ToDo: msg!)")
444 choose_no2 -- arbitrary
446 panic "RnPass2: need original modules for imported instances"
449 -- now we *cheat*: so we can use the "informing module" stuff
450 -- in "selByBetterName", we *make up* some ProtoNames for
451 -- these instance decls
453 ii = SLIT("!*INSTANCE*!")
454 n1 = Imp orig_mod1 ii [infor_mod1] ii
455 n2 = Imp orig_mod2 ii [infor_mod2] ii
457 selByBetterName "instance"
460 (\ p -> InstDecl c ty bs from_here1 orig_mod1 infor_mod1
467 chooser_Inst wout iprags1 loc1 i1 iprags2 loc2 i2
468 = chk_pragmas iprags1 iprags2
471 chk_pragmas NoInstancePragmas b = returnRn12 (wout b)
472 chk_pragmas a NoInstancePragmas = returnRn12 (wout a)
474 -- SimpleInstance pragmas meet: choose by GenPragmas
475 chk_pragmas (SimpleInstancePragma gprags1) (SimpleInstancePragma gprags2)
476 = recoverQuietlyRn12 NoGenPragmas (
477 selGenPragmas gprags1 loc1 gprags2 loc2
478 ) `thenRn12` \ new_prags ->
481 NoGenPragmas -> NoInstancePragmas -- bottled out
482 _ -> SimpleInstancePragma new_prags
485 -- SimpleInstance pragma meets anything else... take the "else"
486 chk_pragmas (SimpleInstancePragma _) b = returnRn12 (wout b)
487 chk_pragmas a (SimpleInstancePragma _) = returnRn12 (wout a)
489 chk_pragmas (ConstantInstancePragma gp1 prs1) (ConstantInstancePragma gp2 prs2)
490 = recoverQuietlyRn12 NoGenPragmas (
491 selGenPragmas gp1 loc1 gp2 loc2
492 ) `thenRn12` \ dfun_prags ->
494 recoverQuietlyRn12 [] (
495 selNamePragmaPairs prs1 loc1 prs2 loc2
496 ) `thenRn12` \ new_pairs ->
499 if null new_pairs then -- bottled out
501 NoGenPragmas -> NoInstancePragmas -- doubly bottled out
502 _ -> SimpleInstancePragma dfun_prags
504 ConstantInstancePragma dfun_prags new_pairs
507 -- SpecialisedInstancePragmas: choose by gens, then specialisations
508 chk_pragmas a@(SpecialisedInstancePragma _ _) (SpecialisedInstancePragma _ _)
509 = trace "not checking two SpecialisedInstancePragma pragmas!" (returnRn12 (wout a))
511 chk_pragmas other1 other2 -- oops, bad mismatch
512 = pRAGMA_ERROR "instance pragmas" (wout other1) -- ToDo: msg
515 %************************************************************************
517 \subsection[SpecInstSigs-RnPass2]{Functions for @AbstractTypeSigs@}
519 %************************************************************************
521 We don't make any effort to look for duplicate ``SPECIALIZE instance''
524 We do this by make \tr{cmp*} always return \tr{LT_}---then there's
525 nothing for \tr{sel*} to do!
529 :: ProtoNameSpecInstSig -> ProtoNameSpecInstSig -> TAG_
531 selSpecInstSigs :: ProtoNameSpecInstSig
532 -> ProtoNameSpecInstSig
533 -> Rn12M ProtoNameSpecInstSig
535 cmpSpecInstSigs a b = LT_
536 selSpecInstSigs a b = panic "RnPass2:selSpecInstSigs"
539 %************************************************************************
541 \subsection{Functions for SigDecls}
543 %************************************************************************
545 These \tr{*Sig} functions only operate on things from interfaces, so
546 we don't have to worry about user-pragmas and other such junk.
549 cmpSig :: ProtoNameSig -> ProtoNameSig -> TAG_
551 cmpSig (Sig n1 _ _ _) (Sig n2 _ _ _) = cmpProtoName n1 n2
553 cmpSig _ _ = panic# "cmpSig (rename2)"
555 selSig :: ProtoNameSig -> ProtoNameSig -> Rn12M ProtoNameSig
557 selSig s1@(Sig n1 ty pragmas1 locn1) s2@(Sig n2 _ pragmas2 locn2)
558 = selByBetterName "type signature"
561 (\ p -> Sig n1 ty p locn1) -- w/out its pragmas
566 chooser_Sig wout_prags g1 l1 s1@(Sig n1 ty1 _ _) g2 l2 s2@(Sig n2 ty2 _ _)
567 = case (cmpPolyType cmpProtoName ty1 ty2) of
569 recoverQuietlyRn12 NoGenPragmas (
570 selGenPragmas g1 l1 g2 l2
571 ) `thenRn12` \ new_prags ->
572 returnRn12 (wout_prags new_prags)
573 _ -> report_dup "signature" n1 l1 n2 l2 s1
576 %************************************************************************
578 \subsection{Help functions: selecting based on pragmas}
580 %************************************************************************
584 :: ProtoNameGenPragmas -> SrcLoc
585 -> ProtoNameGenPragmas -> SrcLoc
586 -> Rn12M ProtoNameGenPragmas
588 selGenPragmas NoGenPragmas _ b _ = returnRn12 b
589 selGenPragmas a _ NoGenPragmas _ = returnRn12 a
591 selGenPragmas g1@(GenPragmas arity1 upd1 def1 strict1 unfold1 specs1) locn1
592 g2@(GenPragmas arity2 upd2 def2 strict2 unfold2 specs2) locn2
594 = sel_arity arity1 arity2 `thenRn12` \ arity ->
595 sel_upd upd1 upd2 `thenRn12` \ upd ->
596 sel_def def1 def2 `thenRn12` \ def ->
597 sel_strict strict1 strict2 `thenRn12` \ strict ->
598 sel_unfold unfold1 unfold2 `thenRn12` \ unfold ->
599 sel_specs specs1 specs2 `thenRn12` \ specs ->
600 returnRn12 (GenPragmas arity upd def strict unfold specs)
602 sel_arity Nothing Nothing = returnRn12 Nothing
603 sel_arity a@(Just a1) (Just a2) = if a1 == a2
605 else pRAGMA_ERROR "arity pragmas" a
606 sel_arity a _ = pRAGMA_ERROR "arity pragmas" a
609 sel_upd Nothing Nothing = returnRn12 Nothing
610 sel_upd a@(Just u1) (Just u2) = if u1 == u2
612 else pRAGMA_ERROR "update pragmas" a
613 sel_upd a _ = pRAGMA_ERROR "update pragmas" a
616 sel_def Don'tDeforest Don'tDeforest = returnRn12 Don'tDeforest
617 sel_def DoDeforest DoDeforest = returnRn12 DoDeforest
618 sel_def a _ = pRAGMA_ERROR "deforest pragmas" a
621 sel_unfold NoImpUnfolding b = returnRn12 b
622 sel_unfold a NoImpUnfolding = returnRn12 a
624 sel_unfold a@(ImpUnfolding _ c1) (ImpUnfolding _ c2)
625 = if c1 `eqUfExpr` c2 -- very paranoid (and rightly so)
627 else pprTrace "mismatched unfoldings:\n" (ppAbove (ppr PprDebug c1) (ppr PprDebug c2)) (
628 returnRn12 NoImpUnfolding
631 sel_unfold a@(ImpMagicUnfolding b) (ImpMagicUnfolding c)
632 = if b == c then returnRn12 a else pRAGMA_ERROR "magic unfolding" a
634 sel_unfold a _ = pRAGMA_ERROR "unfolding pragmas" a
637 sel_strict NoImpStrictness NoImpStrictness = returnRn12 NoImpStrictness
639 sel_strict a@(ImpStrictness b1 i1 g1) (ImpStrictness b2 i2 g2)
640 = if b1 /= b2 || i1 /= i2
641 then pRAGMA_ERROR "strictness pragmas" a
642 else recoverQuietlyRn12 NoGenPragmas (
643 selGenPragmas g1 locn1 g2 locn2
644 ) `thenRn12` \ wrkr_prags ->
645 returnRn12 (ImpStrictness b1 i1 wrkr_prags)
647 sel_strict a _ = pRAGMA_ERROR "strictness pragmas" a
650 sel_specs specs1 specs2
651 = selSpecialisations specs1 locn1 specs2 locn2
656 :: [(ProtoName, ProtoNameGenPragmas)] -> SrcLoc
657 -> [(ProtoName, ProtoNameGenPragmas)] -> SrcLoc
658 -> Rn12M [(ProtoName, ProtoNameGenPragmas)]
660 selNamePragmaPairs [] _ [] _ = returnRn12 []
661 selNamePragmaPairs [] _ bs _ = returnRn12 bs
662 selNamePragmaPairs as _ [] _ = returnRn12 as
664 selNamePragmaPairs ((name1, prags1) : pairs1) loc1
665 ((name2, prags2) : pairs2) loc2
667 = if not (name1 `eqProtoName` name2) then
668 -- msg of any kind??? ToDo
669 pRAGMA_ERROR "named pragmas" pairs1
671 selGenPragmas prags1 loc1 prags2 loc2 `thenRn12` \ new_prags ->
672 selNamePragmaPairs pairs1 loc1 pairs2 loc2 `thenRn12` \ rest ->
673 returnRn12 ( (name1, new_prags) : rest )
676 For specialisations we merge the lists from each Sig. This allows the user to
677 declare specialised prelude functions in their own PreludeSpec module.
681 :: [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)] -> SrcLoc
682 -> [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)] -> SrcLoc
683 -> Rn12M [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)]
685 selSpecialisations [] _ [] _ = returnRn12 []
686 selSpecialisations [] _ bs _ = returnRn12 bs -- arguable ... ToDo?
687 selSpecialisations as _ [] _ = returnRn12 as -- ditto
689 selSpecialisations all_specs1@((spec1, dicts1, prags1) : rest_specs1) loc1
690 all_specs2@((spec2, dicts2, prags2) : rest_specs2) loc2
692 = case (cmp_spec spec1 spec2) of
693 LT_ -> selSpecialisations rest_specs1 loc1 all_specs2 loc2
695 returnRn12 ( (spec1, dicts1, prags1) : rest )
697 EQ_ -> ASSERT(dicts1 == dicts2)
698 recoverQuietlyRn12 NoGenPragmas (
699 selGenPragmas prags1 loc1 prags2 loc2
700 ) `thenRn12` \ new_prags ->
701 selSpecialisations rest_specs1 loc1 rest_specs2 loc2
703 returnRn12 ( (spec1, dicts1, new_prags) : rest )
705 GT_ -> selSpecialisations all_specs1 loc1 rest_specs2 loc2
707 returnRn12 ( (spec2, dicts2, prags2) : rest )
710 cmp_spec (Nothing:xs) (Nothing:ys) = cmp_spec xs ys
711 cmp_spec (Just t1:xs) (Just t2:ys) = case cmpMonoType cmpProtoName t1 t2 of
712 EQ_ -> cmp_spec xs ys
714 cmp_spec (Nothing:xs) (Just t2:ys) = LT_
715 cmp_spec (Just t1:xs) (Nothing:ys) = GT_
718 %************************************************************************
720 \subsection{Help functions: @uniquefy@ and @selByBetterName@}
722 %************************************************************************
725 uniquefy :: FAST_STRING -- Module name
726 -> (a -> a -> TAG_) -- Comparison function
727 -> (a -> a -> Rn12M a) -- Selection function
728 -> [a] -- Things to be processed
729 -> Rn12M [a] -- Processed things
731 uniquefy mod cmp sel things
732 = mapRn12 (check_group_consistency sel) grouped_things
734 grouped_things = equivClasses cmp things
736 check_group_consistency :: (a -> a -> Rn12M a) -- Selection function
737 -> [a] -- things to be compared
740 check_group_consistency sel [] = panic "RnPass2: runs produced an empty list"
741 check_group_consistency sel (thing:things) = foldrRn12 sel thing things
744 @selByBetterName@: There are two ways one thing can have a ``better
747 First: Something with an @Unk@ name is declared in this module, so we
748 keep that, rather than something from an interface (with an @Imp@
751 Second: If we have two non-@Unk@ names, but one ``informant module''
752 is also the {\em original} module for the entity, then we choose that
753 one. I.e., if one interface says, ``I am the module that created this
754 thing'' then we believe it and take that one.
756 If we can't figure out which one to choose by the names, we use the
757 info provided to select based on the pragmas.
759 LATER: but surely we have to worry about different-by-original-name
760 things which are same-by-local-name things---these should be reported
764 selByBetterName :: String -- class/datatype/synonym (for error msg)
766 -- 1st/2nd comparee name/pragmas + their things
767 -> ProtoName -> pragmas -> SrcLoc -> thing
768 -> ProtoName -> pragmas -> SrcLoc -> thing
770 -- a thing without its pragmas
771 -> (pragmas -> thing)
773 -- choose-by-pragma function
774 -> ((pragmas -> thing) -- thing minus its pragmas
775 -> pragmas -> SrcLoc -> thing -- comparee 1
776 -> pragmas -> SrcLoc -> thing -- comparee 2
777 -> Rn12M thing ) -- thing w/ its new pragmas
779 -> Rn12M thing -- selected thing
781 selByBetterName dup_msg
782 pn1 pragmas1 locn1 thing1
783 pn2 pragmas2 locn2 thing2
786 = getModuleNameRn12 `thenRn12` \ mod_name ->
788 choose_thing1 = chk_eq (returnRn12 thing1)
789 choose_thing2 = chk_eq (returnRn12 thing2)
790 check_n_choose = chk_eq (chooser thing_wout_pragmas
791 pragmas1 locn1 thing1
792 pragmas2 locn2 thing2)
794 dup_error = report_dup dup_msg pn1 locn1 pn2 locn2 thing1
799 _ -> if orig_modules_clash mod_name pn2
803 Prel _ -> case pn2 of
804 Unk _ -> if orig_modules_clash mod_name pn1
809 Imp om1 _ im1 _ -> -- we're gonna check `informant module' info...
811 Unk _ -> if orig_modules_clash mod_name pn1
814 Prel _ -> check_n_choose
817 is_elem = isIn "selByBetterName"
819 name1_claims_orig = om1 `is_elem` im1 && not (_NULL_ om1)
820 name2_claims_orig = om2 `is_elem` im2 && not (_NULL_ om2)
823 then if name2_claims_orig then check_n_choose else choose_thing1
824 else if name2_claims_orig then choose_thing2 else check_n_choose
827 = if not (eqProtoName pn1 pn2) && eqByLocalName pn1 pn2
828 then report_dup dup_msg pn1 locn1 pn2 locn2 thing1
831 orig_modules_clash this_module pn
832 = case (getOrigName pn) of { (that_module, _) ->
833 not (this_module == that_module) }
835 report_dup dup_msg pn1 locn1 pn2 locn2 thing
836 = addErrRn12 err_msg `thenRn12` \ _ ->
839 err_msg = dupNamesErr dup_msg [(pn1,locn1), (pn2,locn2)]
841 pRAGMA_ERROR :: String -> a -> Rn12M a
843 = addErrRn12 (\ sty -> ppStr ("PRAGMA ERROR:"++msg)) `thenRn12` \ _ ->