ghc/compiler/rename/Rename2.lhs

   1 %
   2 % (c) The GRASP Project, Glasgow University, 1992-1995
   3 %
   4 \section[Rename2]{Second renaming pass: boil down to non-duplicated info}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module Rename2 (
  10         rnModule2,
  11
  12         -- for completeness
  13         Module, Bag, ProtoNamePat(..), InPat,
  14         PprStyle, Pretty(..), PrettyRep, ProtoName
  15     ) where
  16
  17 IMPORT_Trace            -- ToDo: rm (debugging)
  18 import Pretty
  19 import Outputable
  20
  21 import AbsSyn
  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(..) )
  28 import ProtoName
  29 import RenameMonad12
  30 import SrcLoc           ( mkUnknownSrcLoc, SrcLoc )
  31 import Util
  32 \end{code}
  33
  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.
  37
  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
  41 lose!
  42
  43 Similarly, if one has interesting pragmas and one has not, we keep the
  44 former.
  45
  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.
  49
  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]
  54
  55 \begin{code}
  56 rnModule2  :: ProtoNameModule -> Rn12M ProtoNameModule
  57
  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)
  61
  62   = uniquefy mod_name cmpFix selFix fixes
  63                                 `thenRn12` \ fixes ->
  64
  65     uniquefy mod_name cmpTys selTys ty_decls
  66                                 `thenRn12` \ ty_decls ->
  67
  68     uniquefy mod_name cmpTySigs selTySigs absty_sigs
  69                                 `thenRn12` \ absty_sigs ->
  70
  71     uniquefy mod_name cmpClassDecl selClass class_decls
  72                                 `thenRn12` \ class_decls ->
  73
  74     uniquefy mod_name cmpInst selInst inst_decls
  75                                 `thenRn12` \ inst_decls ->
  76
  77     uniquefy mod_name cmpSpecInstSigs selSpecInstSigs specinst_sigs
  78                                 `thenRn12` \ specinst_sigs ->
  79
  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
  83         -- module...
  84         -- Note that we want to do this properly later (ToDo) because imported
  85         -- signatures may differ from those declared in the module itself.
  86
  87     rm_sigs_for_here mod_name int_sigs
  88                                 `thenRn12` \ non_here_int_sigs ->
  89
  90     uniquefy mod_name cmpSig selSig non_here_int_sigs
  91                                  `thenRn12` \ int_sigs ->
  92     returnRn12
  93         (Module mod_name
  94                 exports -- export and import lists are passed along
  95                 imports -- for checking in Rename3; no other reason
  96                 fixes
  97                 ty_decls
  98                 absty_sigs
  99                 class_decls
 100                 inst_decls
 101                 specinst_sigs
 102                 defaults
 103                 binds
 104                 int_sigs
 105                 src_loc)
 106   where
 107     top_level_binders = collectTopLevelBinders binds
 108
 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.
 112
 113     rm_sigs_for_here mod_name [] = returnRn12 []
 114
 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 ->
 117
 118         if  not (name `elemByLocalNames` top_level_binders) then -- no name clash...
 119             returnRn12 (sig : rest_sigs)
 120
 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
 125                 returnRn12 rest_sigs
 126             else
 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
 131                         rest_sigs
 132       where
 133          name_for_this_module (Imp m _ _ _) = m == mod_name
 134          name_for_this_module other         = True
 135 \end{code}
 136
 137 %************************************************************************
 138 %*                                                                      *
 139 \subsection[FixityDecls-Rename2]{Functions for @FixityDecls@}
 140 %*                                                                      *
 141 %************************************************************************
 142
 143 \begin{code}
 144 cmpFix :: ProtoNameFixityDecl -> ProtoNameFixityDecl -> TAG_
 145
 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
 151 cmpFix a              b              = GT_
 152 \end{code}
 153
 154 We are pretty un-fussy about which FixityDecl we keep.
 155
 156 \begin{code}
 157 selFix :: ProtoNameFixityDecl -> ProtoNameFixityDecl -> Rn12M ProtoNameFixityDecl
 158 selFix f1 f2 = returnRn12 f1
 159 \end{code}
 160
 161 %************************************************************************
 162 %*                                                                      *
 163 \subsection[TyDecls-Rename2]{Functions for @TyDecls@}
 164 %*                                                                      *
 165 %************************************************************************
 166
 167 \begin{code}
 168 cmpTys :: ProtoNameTyDecl -> ProtoNameTyDecl -> TAG_
 169
 170 cmpTys (TyData _ n1 _ _ _ _ _) (TyData  _ n2 _ _ _ _ _) = cmpProtoName n1 n2
 171 cmpTys (TyData _ n1 _ _ _ _ _) other                    = LT_
 172 cmpTys (TySynonym n1 _ _ _ _)  (TySynonym n2 _ _ _ _)   = cmpProtoName n1 n2
 173 cmpTys a                       b                        = GT_
 174 \end{code}
 175
 176 \begin{code}
 177 selTys :: ProtoNameTyDecl -> ProtoNameTyDecl
 178        -> Rn12M ProtoNameTyDecl
 179
 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.
 183
 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)
 190        chooser_TyData
 191
 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)
 198         chooser_TySynonym
 199 \end{code}
 200
 201 If only one is ``abstract'' (no condecls), we take the other.
 202
 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.
 206
 207 \begin{code}
 208 chooser_TyData wout pragmas1 locn1 td1@(TyData _ name1 _ cons1 _ _ _)
 209                     pragmas2 locn2 td2@(TyData _ name2 _ cons2 _ _ _)
 210   = let
 211         td1_abstract = null cons1
 212         td2_abstract = null cons2
 213
 214         choose_by_pragmas = sub_chooser pragmas1 pragmas2
 215     in
 216     if td1_abstract && td2_abstract then
 217         choose_by_pragmas
 218
 219     else if td1_abstract then
 220         returnRn12 td2
 221
 222     else if td2_abstract then
 223         returnRn12 td1
 224
 225     else if not (eqConDecls cons1 cons2) then
 226         report_dup "algebraic datatype (mismatched data constuctors)"
 227                     name1 locn1 name2 locn2 td1
 228     else
 229         sub_chooser pragmas1 pragmas2
 230   where
 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 [] []))
 238             )
 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 [] []))
 243             )
 244         else
 245             returnRn12 (wout a)  -- same, pick one
 246
 247     -- ToDo: Should we use selByBetterName ???
 248     -- ToDo: Report errors properly and recover quietly ???
 249
 250     -- ToDo: Should we merge specialisations ???
 251
 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
 256
 257     eq_spec spec1 spec2 = case cmp_spec spec1 spec2 of { EQ_ -> True; _ -> False}
 258
 259     ppr_data_specs specs
 260       = ppBesides [ppStr "_SPECIALISE_ ", pp_the_list [
 261           ppCat [ppLbrack, ppInterleave ppComma (map pp_maybe ty_maybes), ppRbrack]
 262           | ty_maybes <- specs ]]
 263
 264     pp_the_list [p]    = p
 265     pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
 266
 267     pp_maybe Nothing   = pp_NONE
 268     pp_maybe (Just ty) = pprParendMonoType PprDebug ty
 269
 270     pp_NONE = ppStr "_N_"
 271 \end{code}
 272
 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.
 275
 276 \begin{code}
 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
 281     else
 282         sub_chooser pragmas1 pragmas2
 283   where
 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
 287 \end{code}
 288
 289 %************************************************************************
 290 %*                                                                      *
 291 \subsection[DataTypeSigs-Rename2]{Functions for @DataTypeSigs@}
 292 %*                                                                      *
 293 %************************************************************************
 294
 295 \begin{code}
 296 cmpTySigs :: ProtoNameDataTypeSig -> ProtoNameDataTypeSig -> TAG_
 297
 298 cmpTySigs (AbstractTypeSig n1 _) (AbstractTypeSig n2 _)
 299   = cmpProtoName n1 n2
 300 cmpTySigs (SpecDataSig n1 ty1 _) (SpecDataSig n2 ty2 _)
 301   = case cmpProtoName n1 n2 of
 302         EQ_   -> LT_   -- multiple SPECIALIZE data pragmas allowed
 303         other -> other
 304 cmpTySigs (AbstractTypeSig n1 _) (SpecDataSig n2 _ _)
 305   = LT_
 306 cmpTySigs (SpecDataSig n1 _ _) (AbstractTypeSig n2 _)
 307   = GT_
 308
 309 selTySigs :: ProtoNameDataTypeSig
 310           -> ProtoNameDataTypeSig
 311           -> Rn12M ProtoNameDataTypeSig
 312
 313 selTySigs s1@(AbstractTypeSig n1 locn1) s2@(AbstractTypeSig n2 locn2)
 314   = selByBetterName "ABSTRACT user-pragma"
 315         n1 bottom locn1 s1
 316         n2 bottom locn2 s2
 317         bottom bottom
 318   where
 319     bottom = panic "Rename2:selTySigs:AbstractTypeSig"
 320
 321 selTySigs s1@(SpecDataSig n1 ty1 locn1) s2@(SpecDataSig n2 ty2 locn2)
 322   = selByBetterName "ABSTRACT user-pragma"
 323         n1 bottom locn1 s1
 324         n2 bottom locn2 s2
 325         bottom bottom
 326   where
 327     bottom = panic "Rename2:selTySigs:SpecDataSig"
 328 \end{code}
 329
 330 %************************************************************************
 331 %*                                                                      *
 332 \subsection[ClassDecl-Rename2]{Functions for @ClassDecls@}
 333 %*                                                                      *
 334 %************************************************************************
 335
 336 \begin{code}
 337 cmpClassDecl :: ProtoNameClassDecl -> ProtoNameClassDecl -> TAG_
 338
 339 cmpClassDecl (ClassDecl _ n1 _ _ _ _ _) (ClassDecl _ n2 _ _ _ _ _)
 340   = cmpProtoName n1 n2
 341
 342 selClass  :: ProtoNameClassDecl -> ProtoNameClassDecl
 343           -> Rn12M ProtoNameClassDecl
 344
 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)
 351         chooser_Class
 352 \end{code}
 353
 354 \begin{code}
 355 chooser_Class wout NoClassPragmas   _ _ b               _ _ = returnRn12 (wout b)
 356 chooser_Class wout a                _ _ NoClassPragmas  _ _ = returnRn12 (wout a)
 357
 358 chooser_Class wout sd1@(SuperDictPragmas gs1) l1 _ sd2@(SuperDictPragmas gs2) l2 _
 359   = if length gs1 /= length gs2 then    -- urgh
 360        returnRn12 (wout NoClassPragmas)
 361     else
 362         recoverQuietlyRn12 [{-no gen prags-}] (
 363             zipWithRn12 choose_prag gs1 gs2
 364         )                       `thenRn12` \ new_gprags ->
 365         returnRn12 (wout (
 366             if null new_gprags then
 367                 pprTrace "tossed all SuperDictPragmas (rename2):"
 368                          (ppAbove (ppr PprDebug sd1) (ppr PprDebug sd2))
 369                 NoClassPragmas
 370             else
 371                 SuperDictPragmas new_gprags
 372         ))
 373   where
 374     choose_prag g1 g2 = selGenPragmas g1 l1 g2 l2
 375 \end{code}
 376
 377 %************************************************************************
 378 %*                                                                      *
 379 \subsection[InstDecls-Rename2]{Functions for @InstDecls@}
 380 %*                                                                      *
 381 %************************************************************************
 382
 383 \begin{code}
 384 cmpInst :: ProtoNameInstDecl -> ProtoNameInstDecl -> TAG_
 385
 386 cmpInst (InstDecl _ c1 ty1 _ _ _ _ _ _ _) (InstDecl _ c2 ty2 _ _ _ _ _ _ _)
 387   = case cmpProtoName c1 c2 of
 388       EQ_   -> cmpInstanceTypes ty1 ty2
 389       other -> other
 390 \end{code}
 391
 392 Select the instance declaration from the module (rather than an
 393 interface), if it exists.
 394
 395 \begin{code}
 396 selInst :: ProtoNameInstDecl -> ProtoNameInstDecl
 397         -> Rn12M ProtoNameInstDecl
 398
 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)
 401   = let
 402         have_orig_mod1 = not (_NULL_ orig_mod1)
 403         have_orig_mod2 = not (_NULL_ orig_mod2)
 404
 405         choose_no1 = returnRn12 i1
 406         choose_no2 = returnRn12 i2
 407     in
 408         -- generally: try to keep the locally-defined instance decl
 409
 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!)")
 414         choose_no1
 415
 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!)")
 419             choose_no1
 420         else
 421             choose_no1
 422
 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!)")
 426             choose_no2
 427         else
 428             choose_no2
 429
 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
 435         else
 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
 439             let
 440                 ii = SLIT("!*INSTANCE*!")
 441                 n1 = Imp orig_mod1 ii [infor_mod1] ii
 442                 n2 = Imp orig_mod2 ii [infor_mod2] ii
 443             in
 444             selByBetterName "instance"
 445                 n1 pragmas1 locn1 i1
 446                 n2 pragmas2 locn2 i2
 447                 (\ p -> InstDecl ctxt c ty bs from_here1 orig_mod1 infor_mod1
 448                         [{-none-}] p locn1)
 449                 chooser_Inst
 450 \end{code}
 451
 452 \begin{code}
 453 chooser_Inst wout iprags1 loc1 i1 iprags2 loc2 i2
 454   = chk_pragmas iprags1 iprags2
 455   where
 456         -- easy cases:
 457     chk_pragmas NoInstancePragmas b = returnRn12 (wout b)
 458     chk_pragmas a NoInstancePragmas = returnRn12 (wout a)
 459
 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 ->
 465         returnRn12 (wout (
 466             case new_prags of
 467               NoGenPragmas -> NoInstancePragmas -- bottled out
 468               _ -> SimpleInstancePragma new_prags
 469         ))
 470
 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)
 474
 475     chk_pragmas (ConstantInstancePragma gp1 prs1) (ConstantInstancePragma gp2 prs2)
 476       = recoverQuietlyRn12 NoGenPragmas (
 477             selGenPragmas gp1 loc1 gp2 loc2
 478         )                       `thenRn12` \ dfun_prags ->
 479
 480         recoverQuietlyRn12 [] (
 481             selNamePragmaPairs prs1 loc1 prs2 loc2
 482         )                       `thenRn12` \ new_pairs ->
 483
 484         returnRn12 (wout (
 485             if null new_pairs then -- bottled out
 486                 case dfun_prags of
 487                   NoGenPragmas -> NoInstancePragmas -- doubly bottled out
 488                   _ -> SimpleInstancePragma dfun_prags
 489             else
 490                 ConstantInstancePragma dfun_prags new_pairs
 491         ))
 492
 493         -- SpecialisedInstancePragmas: choose by gens, then specialisations
 494     chk_pragmas a@(SpecialisedInstancePragma _ _) (SpecialisedInstancePragma _ _)
 495       = trace "not checking two SpecialisedInstancePragma pragmas!" (returnRn12 (wout a))
 496
 497     chk_pragmas other1 other2  -- oops, bad mismatch
 498       = pRAGMA_ERROR "instance pragmas" (wout other1) -- ToDo: msg
 499 \end{code}
 500
 501 %************************************************************************
 502 %*                                                                      *
 503 \subsection[SpecInstSigs-Rename2]{Functions for @AbstractTypeSigs@}
 504 %*                                                                      *
 505 %************************************************************************
 506
 507 We don't make any effort to look for duplicate ``SPECIALIZE instance''
 508 pragmas. (Later??)
 509
 510 We do this by make \tr{cmp*} always return \tr{LT_}---then there's
 511 nothing for \tr{sel*} to do!
 512
 513 \begin{code}
 514 cmpSpecInstSigs
 515         :: ProtoNameSpecialisedInstanceSig -> ProtoNameSpecialisedInstanceSig -> TAG_
 516 selSpecInstSigs :: ProtoNameSpecialisedInstanceSig
 517                 -> ProtoNameSpecialisedInstanceSig
 518                 -> Rn12M ProtoNameSpecialisedInstanceSig
 519
 520 cmpSpecInstSigs a b = LT_
 521 selSpecInstSigs a b = panic "Rename2:selSpecInstSigs"
 522 \end{code}
 523
 524 %************************************************************************
 525 %*                                                                      *
 526 \subsection{Functions for SigDecls}
 527 %*                                                                      *
 528 %************************************************************************
 529
 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.
 532
 533 \begin{code}
 534 cmpSig :: ProtoNameSig -> ProtoNameSig -> TAG_
 535
 536 cmpSig (Sig n1 _ _ _) (Sig n2 _ _ _) = cmpProtoName n1 n2
 537
 538 -- avoid BUG (ToDo)
 539 cmpSig _ _ = case (panic "cmpSig (rename2)") of { s -> -- should never happen
 540              cmpSig s s }
 541
 542 selSig :: ProtoNameSig -> ProtoNameSig -> Rn12M ProtoNameSig
 543
 544 selSig s1@(Sig n1 ty pragmas1 locn1) s2@(Sig n2 _ pragmas2 locn2)
 545   = selByBetterName "type signature"
 546         n1 pragmas1 locn1 s1
 547         n2 pragmas2 locn2 s2
 548         (\ p -> Sig n1 ty p locn1) -- w/out its pragmas
 549         chooser_Sig
 550 \end{code}
 551
 552 \begin{code}
 553 chooser_Sig wout_prags g1 l1 s1@(Sig n1 ty1 _ _) g2 l2 s2@(Sig n2 ty2 _ _)
 554   = case (cmpPolyType cmpProtoName ty1 ty2) of
 555       EQ_ ->
 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
 561 \end{code}
 562
 563 %************************************************************************
 564 %*                                                                      *
 565 \subsection{Help functions: selecting based on pragmas}
 566 %*                                                                      *
 567 %************************************************************************
 568
 569 \begin{code}
 570 selGenPragmas
 571         :: ProtoNameGenPragmas -> SrcLoc
 572         -> ProtoNameGenPragmas -> SrcLoc
 573         -> Rn12M ProtoNameGenPragmas
 574
 575 selGenPragmas NoGenPragmas _ b            _ = returnRn12 b
 576 selGenPragmas a            _ NoGenPragmas _ = returnRn12 a
 577
 578 selGenPragmas g1@(GenPragmas arity1 upd1 def1 strict1 unfold1 specs1) locn1
 579               g2@(GenPragmas arity2 upd2 def2 strict2 unfold2 specs2) locn2
 580
 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)
 588   where
 589     sel_arity Nothing     Nothing   = returnRn12 Nothing
 590     sel_arity a@(Just a1) (Just a2) = if a1 == a2
 591                                       then returnRn12 a
 592                                       else pRAGMA_ERROR "arity pragmas" a
 593     sel_arity a           _         = pRAGMA_ERROR "arity pragmas" a
 594
 595     -------
 596     sel_upd Nothing     Nothing   = returnRn12 Nothing
 597     sel_upd a@(Just u1) (Just u2) = if u1 == u2
 598                                     then returnRn12 a
 599                                     else pRAGMA_ERROR "update pragmas" a
 600     sel_upd a           _         = pRAGMA_ERROR "update pragmas" a
 601
 602     -------
 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
 606
 607     ----------
 608     sel_unfold NoImpUnfolding b              = returnRn12 b
 609     sel_unfold a              NoImpUnfolding = returnRn12 a
 610
 611     sel_unfold a@(ImpUnfolding _ c1) (ImpUnfolding _ c2)
 612       = if c1 `eqUfExpr` c2 -- very paranoid (and rightly so)
 613         then returnRn12 a
 614         else pprTrace "mismatched unfoldings:\n" (ppAbove (ppr PprDebug c1) (ppr PprDebug c2)) (
 615              returnRn12 NoImpUnfolding
 616              )
 617
 618     sel_unfold a@(ImpMagicUnfolding b) (ImpMagicUnfolding c)
 619       = if b == c then returnRn12 a else pRAGMA_ERROR "magic unfolding" a
 620
 621     sel_unfold a _ = pRAGMA_ERROR "unfolding pragmas" a
 622
 623     ----------
 624     sel_strict NoImpStrictness NoImpStrictness = returnRn12 NoImpStrictness
 625
 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)
 633
 634     sel_strict a _ = pRAGMA_ERROR "strictness pragmas" a
 635
 636     ---------
 637     sel_specs specs1 specs2
 638       = selSpecialisations specs1 locn1 specs2 locn2
 639 \end{code}
 640
 641 \begin{code}
 642 selNamePragmaPairs
 643         :: [(ProtoName, ProtoNameGenPragmas)] -> SrcLoc
 644         -> [(ProtoName, ProtoNameGenPragmas)] -> SrcLoc
 645         -> Rn12M [(ProtoName, ProtoNameGenPragmas)]
 646
 647 selNamePragmaPairs [] _ [] _ = returnRn12 []
 648 selNamePragmaPairs [] _ bs _ = returnRn12 bs
 649 selNamePragmaPairs as _ [] _ = returnRn12 as
 650
 651 selNamePragmaPairs ((name1, prags1) : pairs1) loc1
 652                    ((name2, prags2) : pairs2) loc2
 653
 654   = if not (name1 `eqProtoName` name2) then
 655         -- msg of any kind??? ToDo
 656         pRAGMA_ERROR "named pragmas" pairs1
 657     else
 658         selGenPragmas prags1 loc1 prags2 loc2       `thenRn12` \ new_prags ->
 659         selNamePragmaPairs pairs1 loc1 pairs2 loc2  `thenRn12` \ rest ->
 660         returnRn12 ( (name1, new_prags) : rest )
 661 \end{code}
 662
 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.
 665
 666 \begin{code}
 667 selSpecialisations
 668         :: [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)] -> SrcLoc
 669         -> [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)] -> SrcLoc
 670         -> Rn12M [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)]
 671
 672 selSpecialisations [] _ [] _ = returnRn12 []
 673 selSpecialisations [] _ bs _ = returnRn12 bs -- arguable ... ToDo?
 674 selSpecialisations as _ [] _ = returnRn12 as -- ditto
 675
 676 selSpecialisations all_specs1@((spec1, dicts1, prags1) : rest_specs1) loc1
 677                    all_specs2@((spec2, dicts2, prags2) : rest_specs2) loc2
 678
 679   = case (cmp_spec spec1 spec2) of
 680          LT_ -> selSpecialisations rest_specs1 loc1 all_specs2 loc2
 681                                         `thenRn12` \ rest ->
 682                 returnRn12 ( (spec1, dicts1, prags1) : rest )
 683
 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
 689                                         `thenRn12` \ rest ->
 690                 returnRn12 ( (spec1, dicts1, new_prags) : rest )
 691
 692          GT_ -> selSpecialisations all_specs1 loc1 rest_specs2 loc2
 693                                         `thenRn12` \ rest ->
 694                 returnRn12 ( (spec2, dicts2, prags2) : rest )
 695
 696 cmp_spec [] []                     = EQ_
 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
 700                                         xxx -> xxx
 701 cmp_spec (Nothing:xs) (Just t2:ys) = LT_
 702 cmp_spec (Just t1:xs) (Nothing:ys) = GT_
 703 \end{code}
 704
 705 %************************************************************************
 706 %*                                                                      *
 707 \subsection{Help functions: @uniquefy@ and @selByBetterName@}
 708 %*                                                                      *
 709 %************************************************************************
 710
 711 \begin{code}
 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
 717
 718 uniquefy mod cmp sel things
 719   = mapRn12 (check_group_consistency sel) grouped_things
 720   where
 721     grouped_things = equivClasses cmp things
 722
 723     check_group_consistency :: (a -> a -> Rn12M a)      -- Selection function
 724                             -> [a]                      -- things to be compared
 725                             -> Rn12M a
 726
 727     check_group_consistency sel []             = panic "Rename2: runs produced an empty list"
 728     check_group_consistency sel (thing:things) = foldrRn12 sel thing things
 729 \end{code}
 730
 731 @selByBetterName@: There are two ways one thing can have a ``better
 732 name'' than another.
 733
 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@
 736 name, probably).
 737
 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.
 742
 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.
 745
 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
 748 as errors.
 749
 750 \begin{code}
 751 selByBetterName :: String   -- class/datatype/synonym (for error msg)
 752
 753                 -- 1st/2nd comparee name/pragmas + their things
 754                 -> ProtoName -> pragmas -> SrcLoc -> thing
 755                 -> ProtoName -> pragmas -> SrcLoc -> thing
 756
 757                 -- a thing without its pragmas
 758                 -> (pragmas -> thing)
 759
 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
 765
 766                 -> Rn12M thing          -- selected thing
 767
 768 selByBetterName dup_msg
 769                 pn1 pragmas1 locn1 thing1
 770                 pn2 pragmas2 locn2 thing2
 771                 thing_wout_pragmas
 772                 chooser
 773   = getModuleNameRn12   `thenRn12` \ mod_name ->
 774     let
 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)
 780
 781         dup_error = report_dup dup_msg pn1 locn1 pn2 locn2 thing1
 782     in
 783     case pn1 of
 784       Unk _  -> case pn2 of
 785                  Unk _  -> dup_error
 786                  _      -> if orig_modules_clash mod_name pn2
 787                             then dup_error
 788                             else choose_thing1
 789
 790       Prel _ -> case pn2 of
 791                  Unk _  -> if orig_modules_clash mod_name pn1
 792                            then dup_error
 793                            else choose_thing2
 794                  _      -> check_n_choose
 795
 796       Imp om1 _ im1 _ -> -- we're gonna check `informant module' info...
 797         case pn2 of
 798           Unk _           -> if orig_modules_clash mod_name pn1
 799                              then dup_error
 800                              else choose_thing2
 801           Prel _          -> check_n_choose
 802           Imp om2 _ im2 _
 803             -> let
 804                    is_elem = isIn "selByBetterName"
 805
 806                    name1_claims_orig = om1 `is_elem` im1 && not (_NULL_ om1)
 807                    name2_claims_orig = om2 `is_elem` im2 && not (_NULL_ om2)
 808                in
 809                if name1_claims_orig
 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
 812   where
 813     chk_eq if_OK
 814       = if not (eqProtoName pn1 pn2) && eqByLocalName pn1 pn2
 815         then report_dup dup_msg pn1 locn1 pn2 locn2 thing1
 816         else if_OK
 817
 818     orig_modules_clash this_module pn
 819       = case (getOrigName pn) of { (that_module, _) ->
 820         not (this_module == that_module) }
 821
 822 report_dup dup_msg pn1 locn1 pn2 locn2 thing
 823   = addErrRn12 err_msg `thenRn12` \ _ ->
 824     returnRn12 thing
 825   where
 826     err_msg = dupNamesErr dup_msg [(pn1,locn1), (pn2,locn2)]
 827
 828 pRAGMA_ERROR :: String -> a -> Rn12M a
 829 pRAGMA_ERROR msg x
 830   = addErrRn12 (\ sty -> ppStr ("PRAGMA ERROR:"++msg)) `thenRn12` \ _ ->
 831     returnRn12 x
 832 \end{code}