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          ( 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     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
 254
 255     ppr_data_specs specs
 256       = ppBesides [ppStr "_SPECIALISE_ ", pp_the_list [
 257           ppCat [ppLbrack, ppInterleave ppComma (map pp_maybe ty_maybes), ppRbrack]
 258           | ty_maybes <- specs ]]
 259
 260     pp_the_list [p]    = p
 261     pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
 262
 263     pp_maybe Nothing   = pp_NONE
 264     pp_maybe (Just ty) = pprParendMonoType PprDebug ty
 265
 266     pp_NONE = ppStr "_N_"
 267 \end{code}
 268
 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.
 271
 272 \begin{code}
 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
 277     else
 278         sub_chooser pragmas1 pragmas2
 279   where
 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
 283 \end{code}
 284
 285 %************************************************************************
 286 %*                                                                      *
 287 \subsection[DataTypeSigs-Rename2]{Functions for @DataTypeSigs@}
 288 %*                                                                      *
 289 %************************************************************************
 290
 291 \begin{code}
 292 cmpTySigs :: ProtoNameDataTypeSig -> ProtoNameDataTypeSig -> TAG_
 293
 294 cmpTySigs (AbstractTypeSig n1 _) (AbstractTypeSig n2 _)
 295   = cmpProtoName n1 n2
 296 cmpTySigs (SpecDataSig n1 ty1 _) (SpecDataSig n2 ty2 _)
 297   = case cmpProtoName n1 n2 of
 298         EQ_   -> LT_   -- multiple SPECIALIZE data pragmas allowed
 299         other -> other
 300 cmpTySigs (AbstractTypeSig n1 _) (SpecDataSig n2 _ _)
 301   = LT_
 302 cmpTySigs (SpecDataSig n1 _ _) (AbstractTypeSig n2 _)
 303   = GT_
 304
 305 selTySigs :: ProtoNameDataTypeSig
 306           -> ProtoNameDataTypeSig
 307           -> Rn12M ProtoNameDataTypeSig
 308
 309 selTySigs s1@(AbstractTypeSig n1 locn1) s2@(AbstractTypeSig n2 locn2)
 310   = selByBetterName "ABSTRACT user-pragma"
 311         n1 bottom locn1 s1
 312         n2 bottom locn2 s2
 313         bottom bottom
 314   where
 315     bottom = panic "Rename2:selTySigs:AbstractTypeSig"
 316
 317 selTySigs s1@(SpecDataSig n1 ty1 locn1) s2@(SpecDataSig n2 ty2 locn2)
 318   = selByBetterName "ABSTRACT user-pragma"
 319         n1 bottom locn1 s1
 320         n2 bottom locn2 s2
 321         bottom bottom
 322   where
 323     bottom = panic "Rename2:selTySigs:SpecDataSig"
 324 \end{code}
 325
 326 %************************************************************************
 327 %*                                                                      *
 328 \subsection[ClassDecl-Rename2]{Functions for @ClassDecls@}
 329 %*                                                                      *
 330 %************************************************************************
 331
 332 \begin{code}
 333 cmpClassDecl :: ProtoNameClassDecl -> ProtoNameClassDecl -> TAG_
 334
 335 cmpClassDecl (ClassDecl _ n1 _ _ _ _ _) (ClassDecl _ n2 _ _ _ _ _)
 336   = cmpProtoName n1 n2
 337
 338 selClass  :: ProtoNameClassDecl -> ProtoNameClassDecl
 339           -> Rn12M ProtoNameClassDecl
 340
 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)
 347         chooser_Class
 348 \end{code}
 349
 350 \begin{code}
 351 chooser_Class wout NoClassPragmas   _ _ b               _ _ = returnRn12 (wout b)
 352 chooser_Class wout a                _ _ NoClassPragmas  _ _ = returnRn12 (wout a)
 353
 354 chooser_Class wout sd1@(SuperDictPragmas gs1) l1 _ sd2@(SuperDictPragmas gs2) l2 _
 355   = if length gs1 /= length gs2 then    -- urgh
 356        returnRn12 (wout NoClassPragmas)
 357     else
 358         recoverQuietlyRn12 [{-no gen prags-}] (
 359             zipWithRn12 choose_prag gs1 gs2
 360         )                       `thenRn12` \ new_gprags ->
 361         returnRn12 (wout (
 362             if null new_gprags then
 363                 pprTrace "tossed all SuperDictPragmas (rename2):"
 364                          (ppAbove (ppr PprDebug sd1) (ppr PprDebug sd2))
 365                 NoClassPragmas
 366             else
 367                 SuperDictPragmas new_gprags
 368         ))
 369   where
 370     choose_prag g1 g2 = selGenPragmas g1 l1 g2 l2
 371 \end{code}
 372
 373 %************************************************************************
 374 %*                                                                      *
 375 \subsection[InstDecls-Rename2]{Functions for @InstDecls@}
 376 %*                                                                      *
 377 %************************************************************************
 378
 379 \begin{code}
 380 cmpInst :: ProtoNameInstDecl -> ProtoNameInstDecl -> TAG_
 381
 382 cmpInst (InstDecl _ c1 ty1 _ _ _ _ _ _ _) (InstDecl _ c2 ty2 _ _ _ _ _ _ _)
 383   = case cmpProtoName c1 c2 of
 384       EQ_   -> cmpInstanceTypes ty1 ty2
 385       other -> other
 386 \end{code}
 387
 388 Select the instance declaration from the module (rather than an
 389 interface), if it exists.
 390
 391 \begin{code}
 392 selInst :: ProtoNameInstDecl -> ProtoNameInstDecl
 393         -> Rn12M ProtoNameInstDecl
 394
 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)
 397   = let
 398         have_orig_mod1 = not (_NULL_ orig_mod1)
 399         have_orig_mod2 = not (_NULL_ orig_mod2)
 400
 401         choose_no1 = returnRn12 i1
 402         choose_no2 = returnRn12 i2
 403     in
 404         -- generally: try to keep the locally-defined instance decl
 405
 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!)")
 410         choose_no1
 411
 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!)")
 415             choose_no1
 416         else
 417             choose_no1
 418
 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!)")
 422             choose_no2
 423         else
 424             choose_no2
 425
 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
 431         else
 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
 435             let
 436                 ii = SLIT("!*INSTANCE*!")
 437                 n1 = Imp orig_mod1 ii [infor_mod1] ii
 438                 n2 = Imp orig_mod2 ii [infor_mod2] ii
 439             in
 440             selByBetterName "instance"
 441                 n1 pragmas1 locn1 i1
 442                 n2 pragmas2 locn2 i2
 443                 (\ p -> InstDecl ctxt c ty bs from_here1 orig_mod1 infor_mod1
 444                         [{-none-}] p locn1)
 445                 chooser_Inst
 446 \end{code}
 447
 448 \begin{code}
 449 chooser_Inst wout iprags1 loc1 i1 iprags2 loc2 i2
 450   = chk_pragmas iprags1 iprags2
 451   where
 452         -- easy cases:
 453     chk_pragmas NoInstancePragmas b = returnRn12 (wout b)
 454     chk_pragmas a NoInstancePragmas = returnRn12 (wout a)
 455
 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 ->
 461         returnRn12 (wout (
 462             case new_prags of
 463               NoGenPragmas -> NoInstancePragmas -- bottled out
 464               _ -> SimpleInstancePragma new_prags
 465         ))
 466
 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)
 470
 471     chk_pragmas (ConstantInstancePragma gp1 prs1) (ConstantInstancePragma gp2 prs2)
 472       = recoverQuietlyRn12 NoGenPragmas (
 473             selGenPragmas gp1 loc1 gp2 loc2
 474         )                       `thenRn12` \ dfun_prags ->
 475
 476         recoverQuietlyRn12 [] (
 477             selNamePragmaPairs prs1 loc1 prs2 loc2
 478         )                       `thenRn12` \ new_pairs ->
 479
 480         returnRn12 (wout (
 481             if null new_pairs then -- bottled out
 482                 case dfun_prags of
 483                   NoGenPragmas -> NoInstancePragmas -- doubly bottled out
 484                   _ -> SimpleInstancePragma dfun_prags
 485             else
 486                 ConstantInstancePragma dfun_prags new_pairs
 487         ))
 488
 489         -- SpecialisedInstancePragmas: choose by gens, then specialisations
 490     chk_pragmas a@(SpecialisedInstancePragma _ _) (SpecialisedInstancePragma _ _)
 491       = trace "not checking two SpecialisedInstancePragma pragmas!" (returnRn12 (wout a))
 492
 493     chk_pragmas other1 other2  -- oops, bad mismatch
 494       = pRAGMA_ERROR "instance pragmas" (wout other1) -- ToDo: msg
 495 \end{code}
 496
 497 %************************************************************************
 498 %*                                                                      *
 499 \subsection[SpecInstSigs-Rename2]{Functions for @AbstractTypeSigs@}
 500 %*                                                                      *
 501 %************************************************************************
 502
 503 We don't make any effort to look for duplicate ``SPECIALIZE instance''
 504 pragmas. (Later??)
 505
 506 We do this by make \tr{cmp*} always return \tr{LT_}---then there's
 507 nothing for \tr{sel*} to do!
 508
 509 \begin{code}
 510 cmpSpecInstSigs
 511         :: ProtoNameSpecialisedInstanceSig -> ProtoNameSpecialisedInstanceSig -> TAG_
 512 selSpecInstSigs :: ProtoNameSpecialisedInstanceSig
 513                 -> ProtoNameSpecialisedInstanceSig
 514                 -> Rn12M ProtoNameSpecialisedInstanceSig
 515
 516 cmpSpecInstSigs a b = LT_
 517 selSpecInstSigs a b = panic "Rename2:selSpecInstSigs"
 518 \end{code}
 519
 520 %************************************************************************
 521 %*                                                                      *
 522 \subsection{Functions for SigDecls}
 523 %*                                                                      *
 524 %************************************************************************
 525
 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.
 528
 529 \begin{code}
 530 cmpSig :: ProtoNameSig -> ProtoNameSig -> TAG_
 531
 532 cmpSig (Sig n1 _ _ _) (Sig n2 _ _ _) = cmpProtoName n1 n2
 533
 534 -- avoid BUG (ToDo)
 535 cmpSig _ _ = case (panic "cmpSig (rename2)") of { s -> -- should never happen
 536              cmpSig s s }
 537
 538 selSig :: ProtoNameSig -> ProtoNameSig -> Rn12M ProtoNameSig
 539
 540 selSig s1@(Sig n1 ty pragmas1 locn1) s2@(Sig n2 _ pragmas2 locn2)
 541   = selByBetterName "type signature"
 542         n1 pragmas1 locn1 s1
 543         n2 pragmas2 locn2 s2
 544         (\ p -> Sig n1 ty p locn1) -- w/out its pragmas
 545         chooser_Sig
 546 \end{code}
 547
 548 \begin{code}
 549 chooser_Sig wout_prags g1 l1 s1@(Sig n1 ty1 _ _) g2 l2 s2@(Sig n2 ty2 _ _)
 550   = case (cmpPolyType cmpProtoName ty1 ty2) of
 551       EQ_ ->
 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
 557 \end{code}
 558
 559 %************************************************************************
 560 %*                                                                      *
 561 \subsection{Help functions: selecting based on pragmas}
 562 %*                                                                      *
 563 %************************************************************************
 564
 565 \begin{code}
 566 selGenPragmas
 567         :: ProtoNameGenPragmas -> SrcLoc
 568         -> ProtoNameGenPragmas -> SrcLoc
 569         -> Rn12M ProtoNameGenPragmas
 570
 571 selGenPragmas NoGenPragmas _ b            _ = returnRn12 b
 572 selGenPragmas a            _ NoGenPragmas _ = returnRn12 a
 573
 574 selGenPragmas g1@(GenPragmas arity1 upd1 def1 strict1 unfold1 specs1) locn1
 575               g2@(GenPragmas arity2 upd2 def2 strict2 unfold2 specs2) locn2
 576
 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)
 584   where
 585     sel_arity Nothing     Nothing   = returnRn12 Nothing
 586     sel_arity a@(Just a1) (Just a2) = if a1 == a2
 587                                       then returnRn12 a
 588                                       else pRAGMA_ERROR "arity pragmas" a
 589     sel_arity a           _         = pRAGMA_ERROR "arity pragmas" a
 590
 591     -------
 592     sel_upd Nothing     Nothing   = returnRn12 Nothing
 593     sel_upd a@(Just u1) (Just u2) = if u1 == u2
 594                                     then returnRn12 a
 595                                     else pRAGMA_ERROR "update pragmas" a
 596     sel_upd a           _         = pRAGMA_ERROR "update pragmas" a
 597
 598     -------
 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
 602
 603     ----------
 604     sel_unfold NoImpUnfolding b              = returnRn12 b
 605     sel_unfold a              NoImpUnfolding = returnRn12 a
 606
 607     sel_unfold a@(ImpUnfolding _ c1) (ImpUnfolding _ c2)
 608       = if c1 `eqUfExpr` c2 -- very paranoid (and rightly so)
 609         then returnRn12 a
 610         else pprTrace "mismatched unfoldings:\n" (ppAbove (ppr PprDebug c1) (ppr PprDebug c2)) (
 611              returnRn12 NoImpUnfolding
 612              )
 613
 614     sel_unfold a@(ImpMagicUnfolding b) (ImpMagicUnfolding c)
 615       = if b == c then returnRn12 a else pRAGMA_ERROR "magic unfolding" a
 616
 617     sel_unfold a _ = pRAGMA_ERROR "unfolding pragmas" a
 618
 619     ----------
 620     sel_strict NoImpStrictness NoImpStrictness = returnRn12 NoImpStrictness
 621
 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)
 629
 630     sel_strict a _ = pRAGMA_ERROR "strictness pragmas" a
 631
 632     ---------
 633     sel_specs specs1 specs2
 634       = selSpecialisations specs1 locn1 specs2 locn2
 635 \end{code}
 636
 637 \begin{code}
 638 selNamePragmaPairs
 639         :: [(ProtoName, ProtoNameGenPragmas)] -> SrcLoc
 640         -> [(ProtoName, ProtoNameGenPragmas)] -> SrcLoc
 641         -> Rn12M [(ProtoName, ProtoNameGenPragmas)]
 642
 643 selNamePragmaPairs [] _ [] _ = returnRn12 []
 644 selNamePragmaPairs [] _ bs _ = returnRn12 bs
 645 selNamePragmaPairs as _ [] _ = returnRn12 as
 646
 647 selNamePragmaPairs ((name1, prags1) : pairs1) loc1
 648                    ((name2, prags2) : pairs2) loc2
 649
 650   = if not (name1 `eqProtoName` name2) then
 651         -- msg of any kind??? ToDo
 652         pRAGMA_ERROR "named pragmas" pairs1
 653     else
 654         selGenPragmas prags1 loc1 prags2 loc2       `thenRn12` \ new_prags ->
 655         selNamePragmaPairs pairs1 loc1 pairs2 loc2  `thenRn12` \ rest ->
 656         returnRn12 ( (name1, new_prags) : rest )
 657 \end{code}
 658
 659 \begin{code}
 660 selSpecialisations
 661         :: [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)] -> SrcLoc
 662         -> [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)] -> SrcLoc
 663         -> Rn12M [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)]
 664
 665 selSpecialisations [] _ [] _ = returnRn12 []
 666 selSpecialisations [] _ bs _ = returnRn12 bs -- arguable ... ToDo?
 667 selSpecialisations as _ [] _ = returnRn12 as -- ditto
 668
 669 selSpecialisations ((spec1, dicts1, prags1) : specs1) loc1
 670                    ((spec2, dicts2, prags2) : specs2) loc2
 671
 672   = if not (eq_spec spec1 spec2) || dicts1 /= dicts2 then
 673         -- msg of any kind??? ToDo
 674         pRAGMA_ERROR "specialisation pragmas" specs1
 675     else
 676         recoverQuietlyRn12 NoGenPragmas (
 677             selGenPragmas prags1 loc1 prags2 loc2
 678         )                               `thenRn12` \ new_prags ->
 679         selSpecialisations specs1 loc1 specs2 loc2
 680                                         `thenRn12` \ rest ->
 681         returnRn12 ( (spec1, dicts1, new_prags) : rest )
 682
 683 eq_spec [] []                     = True
 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
 686 eq_spec _  _                      = False
 687 \end{code}
 688
 689 %************************************************************************
 690 %*                                                                      *
 691 \subsection{Help functions: @uniquefy@ and @selByBetterName@}
 692 %*                                                                      *
 693 %************************************************************************
 694
 695 \begin{code}
 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
 701
 702 uniquefy mod cmp sel things
 703   = mapRn12 (check_group_consistency sel) grouped_things
 704   where
 705     grouped_things = equivClasses cmp things
 706
 707     check_group_consistency :: (a -> a -> Rn12M a)      -- Selection function
 708                             -> [a]                      -- things to be compared
 709                             -> Rn12M a
 710
 711     check_group_consistency sel []             = panic "Rename2: runs produced an empty list"
 712     check_group_consistency sel (thing:things) = foldrRn12 sel thing things
 713 \end{code}
 714
 715 @selByBetterName@: There are two ways one thing can have a ``better
 716 name'' than another.
 717
 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@
 720 name, probably).
 721
 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.
 726
 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.
 729
 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
 732 as errors.
 733
 734 \begin{code}
 735 selByBetterName :: String   -- class/datatype/synonym (for error msg)
 736
 737                 -- 1st/2nd comparee name/pragmas + their things
 738                 -> ProtoName -> pragmas -> SrcLoc -> thing
 739                 -> ProtoName -> pragmas -> SrcLoc -> thing
 740
 741                 -- a thing without its pragmas
 742                 -> (pragmas -> thing)
 743
 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
 749
 750                 -> Rn12M thing          -- selected thing
 751
 752 selByBetterName dup_msg
 753                 pn1 pragmas1 locn1 thing1
 754                 pn2 pragmas2 locn2 thing2
 755                 thing_wout_pragmas
 756                 chooser
 757   = getModuleNameRn12   `thenRn12` \ mod_name ->
 758     let
 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)
 764
 765         dup_error = report_dup dup_msg pn1 locn1 pn2 locn2 thing1
 766     in
 767     case pn1 of
 768       Unk _  -> case pn2 of
 769                  Unk _  -> dup_error
 770                  _      -> if orig_modules_clash mod_name pn2
 771                             then dup_error
 772                             else choose_thing1
 773
 774       Prel _ -> case pn2 of
 775                  Unk _  -> if orig_modules_clash mod_name pn1
 776                            then dup_error
 777                            else choose_thing2
 778                  _      -> check_n_choose
 779
 780       Imp om1 _ im1 _ -> -- we're gonna check `informant module' info...
 781         case pn2 of
 782           Unk _           -> if orig_modules_clash mod_name pn1
 783                              then dup_error
 784                              else choose_thing2
 785           Prel _          -> check_n_choose
 786           Imp om2 _ im2 _
 787             -> let
 788                    is_elem = isIn "selByBetterName"
 789
 790                    name1_claims_orig = om1 `is_elem` im1 && not (_NULL_ om1)
 791                    name2_claims_orig = om2 `is_elem` im2 && not (_NULL_ om2)
 792                in
 793                if name1_claims_orig
 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
 796   where
 797     chk_eq if_OK
 798       = if not (eqProtoName pn1 pn2) && eqByLocalName pn1 pn2
 799         then report_dup dup_msg pn1 locn1 pn2 locn2 thing1
 800         else if_OK
 801
 802     orig_modules_clash this_module pn
 803       = case (getOrigName pn) of { (that_module, _) ->
 804         not (this_module == that_module) }
 805
 806 report_dup dup_msg pn1 locn1 pn2 locn2 thing
 807   = addErrRn12 err_msg `thenRn12` \ _ ->
 808     returnRn12 thing
 809   where
 810     err_msg = dupNamesErr dup_msg [(pn1,locn1), (pn2,locn2)]
 811
 812 pRAGMA_ERROR :: String -> a -> Rn12M a
 813 pRAGMA_ERROR msg x
 814   = addErrRn12 (\ sty -> ppStr ("PRAGMA ERROR:"++msg)) `thenRn12` \ _ ->
 815     returnRn12 x
 816 \end{code}