ghc/compiler/rename/RnPass2.lhs

   1 %
   2 % (c) The GRASP Project, Glasgow University, 1992-1996
   3 %
   4 \section[RnPass2]{Second renaming pass: boil down to non-duplicated info}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module RnPass2 (
  10         rnModule2
  11
  12         -- for completeness
  13     ) where
  14
  15 import Ubiq{-uitous-}
  16
  17 import HsSyn
  18 import HsCore
  19 import HsPragmas
  20 import RdrHsSyn
  21 import RnMonad12
  22
  23 import Bag              ( Bag )
  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,
  30                           ProtoName(..)
  31                         )
  32 import RnUtils          ( dupNamesErr )
  33 import SrcLoc           ( mkUnknownSrcLoc, SrcLoc{-instances-} )
  34 import Util             ( isIn, equivClasses,
  35                           panic, panic#, pprTrace, assertPanic
  36                         )
  37 \end{code}
  38
  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.
  42
  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
  46 lose!
  47
  48 Similarly, if one has interesting pragmas and one has not, we keep the
  49 former.
  50
  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.
  54
  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]
  59
  60 \begin{code}
  61 rnModule2  :: ProtoNameHsModule -> Rn12M ProtoNameHsModule
  62
  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)
  66
  67   = uniquefy mod_name cmpFix selFix fixes
  68                                 `thenRn12` \ fixes ->
  69
  70     uniquefy mod_name cmpTys selTys ty_decls
  71                                 `thenRn12` \ ty_decls ->
  72
  73     uniquefy mod_name cmpTySigs selTySigs absty_sigs
  74                                 `thenRn12` \ absty_sigs ->
  75
  76     uniquefy mod_name cmpClassDecl selClass class_decls
  77                                 `thenRn12` \ class_decls ->
  78
  79     uniquefy mod_name cmpInst selInst inst_decls
  80                                 `thenRn12` \ inst_decls ->
  81
  82     uniquefy mod_name cmpSpecInstSigs selSpecInstSigs specinst_sigs
  83                                 `thenRn12` \ specinst_sigs ->
  84
  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
  88         -- module...
  89         -- Note that we want to do this properly later (ToDo) because imported
  90         -- signatures may differ from those declared in the module itself.
  91
  92     rm_sigs_for_here mod_name int_sigs
  93                                 `thenRn12` \ non_here_int_sigs ->
  94
  95     uniquefy mod_name cmpSig selSig non_here_int_sigs
  96                                  `thenRn12` \ int_sigs ->
  97     returnRn12
  98         (HsModule mod_name
  99                   exports   -- export and import lists are passed along
 100                   imports   -- for checking in RnPass3; no other reason
 101                   fixes
 102                   ty_decls
 103                   absty_sigs
 104                   class_decls
 105                   inst_decls
 106                   specinst_sigs
 107                   defaults
 108                   binds
 109                   int_sigs
 110                   src_loc)
 111   where
 112     top_level_binders = collectTopLevelBinders binds
 113
 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.
 117
 118     rm_sigs_for_here mod_name [] = returnRn12 []
 119
 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 ->
 122
 123         if  not (name `elemByLocalNames` top_level_binders) then -- no name clash...
 124             returnRn12 (sig : rest_sigs)
 125
 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
 130                 returnRn12 rest_sigs
 131             else
 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
 136                         rest_sigs
 137       where
 138          name_for_this_module (Imp m _ _ _) = m == mod_name
 139          name_for_this_module other         = True
 140 \end{code}
 141
 142 %************************************************************************
 143 %*                                                                      *
 144 \subsection[FixityDecls-RnPass2]{Functions for @FixityDecls@}
 145 %*                                                                      *
 146 %************************************************************************
 147
 148 \begin{code}
 149 cmpFix :: ProtoNameFixityDecl -> ProtoNameFixityDecl -> TAG_
 150
 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
 156 cmpFix a              b              = GT_
 157 \end{code}
 158
 159 We are pretty un-fussy about which FixityDecl we keep.
 160
 161 \begin{code}
 162 selFix :: ProtoNameFixityDecl -> ProtoNameFixityDecl -> Rn12M ProtoNameFixityDecl
 163 selFix f1 f2 = returnRn12 f1
 164 \end{code}
 165
 166 %************************************************************************
 167 %*                                                                      *
 168 \subsection[TyDecls-RnPass2]{Functions for @TyDecls@}
 169 %*                                                                      *
 170 %************************************************************************
 171
 172 \begin{code}
 173 cmpTys :: ProtoNameTyDecl -> ProtoNameTyDecl -> TAG_
 174
 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
 178 cmpTys a b
 179   = let tag1 = tag a
 180         tag2 = tag b
 181     in
 182     if tag1 _LT_ tag2 then LT_ else GT_
 183   where
 184     tag (TyData    _ _ _ _ _ _ _) = (ILIT(1) :: FAST_INT)
 185     tag (TyNew     _ _ _ _ _ _ _) = ILIT(2)
 186     tag (TySynonym _ _ _ _)       = ILIT(3)
 187 \end{code}
 188
 189 \begin{code}
 190 selTys :: ProtoNameTyDecl -> ProtoNameTyDecl
 191        -> Rn12M ProtoNameTyDecl
 192
 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.
 196
 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)
 203        chooser_TyData
 204
 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)
 211        chooser_TyNew
 212
 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)
 219         chooser_TySynonym
 220   where
 221     bottom = panic "RnPass2:selTys:TySynonym"
 222 \end{code}
 223
 224 If only one is ``abstract'' (no condecls), we take the other.
 225
 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.
 229
 230 \begin{code}
 231 chooser_TyNew  wout pragmas1 locn1 td1@(TyNew _ name1 _ con1 _ _ _)
 232                     pragmas2 locn2 td2@(TyNew _ name2 _ con2 _ _ _)
 233   = panic "RnPass2:chooser_TyNew"
 234
 235
 236 chooser_TyData wout pragmas1 locn1 td1@(TyData _ name1 _ cons1 _ _ _)
 237                     pragmas2 locn2 td2@(TyData _ name2 _ cons2 _ _ _)
 238   = let
 239         td1_abstract = null cons1
 240         td2_abstract = null cons2
 241
 242         choose_by_pragmas = sub_chooser pragmas1 pragmas2
 243     in
 244     if td1_abstract && td2_abstract then
 245         choose_by_pragmas
 246
 247     else if td1_abstract then
 248         returnRn12 td2
 249
 250     else if td2_abstract then
 251         returnRn12 td1
 252
 253     else if not (eqConDecls cons1 cons2) then
 254         report_dup "algebraic datatype (mismatched data constuctors)"
 255                     name1 locn1 name2 locn2 td1
 256     else
 257         sub_chooser pragmas1 pragmas2
 258   where
 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 [] []))
 266             )
 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 [] []))
 271             )
 272         else
 273             returnRn12 (wout a)  -- same, pick one
 274
 275     -- ToDo: Should we use selByBetterName ???
 276     -- ToDo: Report errors properly and recover quietly ???
 277
 278     -- ToDo: Should we merge specialisations ???
 279
 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
 284
 285     eq_spec spec1 spec2 = case cmp_spec spec1 spec2 of { EQ_ -> True; _ -> False}
 286
 287     ppr_data_specs specs
 288       = ppBesides [ppStr "_SPECIALISE_ ", pp_the_list [
 289           ppCat [ppLbrack, ppInterleave ppComma (map pp_maybe ty_maybes), ppRbrack]
 290           | ty_maybes <- specs ]]
 291
 292     pp_the_list [p]    = p
 293     pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
 294
 295     pp_maybe Nothing   = pp_NONE
 296     pp_maybe (Just ty) = pprParendMonoType PprDebug ty
 297
 298     pp_NONE = ppStr "_N_"
 299 \end{code}
 300
 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.
 303
 304 \begin{code}
 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
 309     else
 310         returnRn12 ts1 -- same, just pick one
 311 \end{code}
 312
 313 %************************************************************************
 314 %*                                                                      *
 315 \subsection[SpecDataSigs-RnPass2]{Functions for @SpecDataSigs@}
 316 %*                                                                      *
 317 %************************************************************************
 318
 319 \begin{code}
 320 cmpTySigs :: ProtoNameSpecDataSig -> ProtoNameSpecDataSig -> TAG_
 321
 322 cmpTySigs (SpecDataSig n1 ty1 _) (SpecDataSig n2 ty2 _)
 323   = case cmpProtoName n1 n2 of
 324         EQ_   -> LT_   -- multiple SPECIALIZE data pragmas allowed
 325         other -> other
 326
 327 selTySigs :: ProtoNameSpecDataSig
 328           -> ProtoNameSpecDataSig
 329           -> Rn12M ProtoNameSpecDataSig
 330
 331 selTySigs s1@(SpecDataSig n1 ty1 locn1) s2@(SpecDataSig n2 ty2 locn2)
 332   = selByBetterName "SPECIALIZE data user-pragma"
 333         n1 bottom locn1 s1
 334         n2 bottom locn2 s2
 335         bottom bottom
 336   where
 337     bottom = panic "RnPass2:selTySigs:SpecDataSig"
 338 \end{code}
 339
 340 %************************************************************************
 341 %*                                                                      *
 342 \subsection[ClassDecl-RnPass2]{Functions for @ClassDecls@}
 343 %*                                                                      *
 344 %************************************************************************
 345
 346 \begin{code}
 347 cmpClassDecl :: ProtoNameClassDecl -> ProtoNameClassDecl -> TAG_
 348
 349 cmpClassDecl (ClassDecl _ n1 _ _ _ _ _) (ClassDecl _ n2 _ _ _ _ _)
 350   = cmpProtoName n1 n2
 351
 352 selClass  :: ProtoNameClassDecl -> ProtoNameClassDecl
 353           -> Rn12M ProtoNameClassDecl
 354
 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)
 361         chooser_Class
 362 \end{code}
 363
 364 \begin{code}
 365 chooser_Class wout NoClassPragmas   _ _ b               _ _ = returnRn12 (wout b)
 366 chooser_Class wout a                _ _ NoClassPragmas  _ _ = returnRn12 (wout a)
 367
 368 chooser_Class wout sd1@(SuperDictPragmas gs1) l1 _ sd2@(SuperDictPragmas gs2) l2 _
 369   = if length gs1 /= length gs2 then    -- urgh
 370        returnRn12 (wout NoClassPragmas)
 371     else
 372         recoverQuietlyRn12 [{-no gen prags-}] (
 373             zipWithRn12 choose_prag gs1 gs2
 374         )                       `thenRn12` \ new_gprags ->
 375         returnRn12 (wout (
 376             if null new_gprags then
 377                 pprTrace "tossed all SuperDictPragmas (rename2):"
 378                          (ppAbove (ppr PprDebug sd1) (ppr PprDebug sd2))
 379                 NoClassPragmas
 380             else
 381                 SuperDictPragmas new_gprags
 382         ))
 383   where
 384     choose_prag g1 g2 = selGenPragmas g1 l1 g2 l2
 385 \end{code}
 386
 387 %************************************************************************
 388 %*                                                                      *
 389 \subsection[InstDecls-RnPass2]{Functions for @InstDecls@}
 390 %*                                                                      *
 391 %************************************************************************
 392
 393 \begin{code}
 394 cmpInst :: ProtoNameInstDecl -> ProtoNameInstDecl -> TAG_
 395
 396 cmpInst (InstDecl c1 ty1 _ _ _ _ _ _) (InstDecl c2 ty2 _ _ _ _ _ _)
 397   = case cmpProtoName c1 c2 of
 398       EQ_   -> cmpInstanceTypes ty1 ty2
 399       other -> other
 400 \end{code}
 401
 402 Select the instance declaration from the module (rather than an
 403 interface), if it exists.
 404
 405 \begin{code}
 406 selInst :: ProtoNameInstDecl -> ProtoNameInstDecl
 407         -> Rn12M ProtoNameInstDecl
 408
 409 selInst i1@(InstDecl c ty bs from_here1 orig_mod1 uprags pragmas1 locn1)
 410         i2@(InstDecl _ _  _  from_here2 orig_mod2 _      pragmas2 locn2)
 411   = let
 412         have_orig_mod1 = not (_NULL_ orig_mod1)
 413         have_orig_mod2 = not (_NULL_ orig_mod2)
 414
 415         choose_no1 = returnRn12 i1
 416         choose_no2 = returnRn12 i2
 417     in
 418         -- generally: try to keep the locally-defined instance decl
 419
 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!)")
 424         choose_no1
 425
 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!)")
 429             choose_no1
 430         else
 431             choose_no1
 432
 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!)")
 436             choose_no2
 437         else
 438             choose_no2
 439
 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
 445         else
 446             panic "RnPass2: need original modules for imported instances"
 447
 448 {- LATER ???
 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
 452             let
 453                 ii = SLIT("!*INSTANCE*!")
 454                 n1 = Imp orig_mod1 ii [infor_mod1] ii
 455                 n2 = Imp orig_mod2 ii [infor_mod2] ii
 456             in
 457             selByBetterName "instance"
 458                 n1 pragmas1 locn1 i1
 459                 n2 pragmas2 locn2 i2
 460                 (\ p -> InstDecl c ty bs from_here1 orig_mod1 infor_mod1
 461                         [{-none-}] p locn1)
 462                 chooser_Inst
 463 -}
 464 \end{code}
 465
 466 \begin{code}
 467 chooser_Inst wout iprags1 loc1 i1 iprags2 loc2 i2
 468   = chk_pragmas iprags1 iprags2
 469   where
 470         -- easy cases:
 471     chk_pragmas NoInstancePragmas b = returnRn12 (wout b)
 472     chk_pragmas a NoInstancePragmas = returnRn12 (wout a)
 473
 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 ->
 479         returnRn12 (wout (
 480             case new_prags of
 481               NoGenPragmas -> NoInstancePragmas -- bottled out
 482               _ -> SimpleInstancePragma new_prags
 483         ))
 484
 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)
 488
 489     chk_pragmas (ConstantInstancePragma gp1 prs1) (ConstantInstancePragma gp2 prs2)
 490       = recoverQuietlyRn12 NoGenPragmas (
 491             selGenPragmas gp1 loc1 gp2 loc2
 492         )                       `thenRn12` \ dfun_prags ->
 493
 494         recoverQuietlyRn12 [] (
 495             selNamePragmaPairs prs1 loc1 prs2 loc2
 496         )                       `thenRn12` \ new_pairs ->
 497
 498         returnRn12 (wout (
 499             if null new_pairs then -- bottled out
 500                 case dfun_prags of
 501                   NoGenPragmas -> NoInstancePragmas -- doubly bottled out
 502                   _ -> SimpleInstancePragma dfun_prags
 503             else
 504                 ConstantInstancePragma dfun_prags new_pairs
 505         ))
 506
 507         -- SpecialisedInstancePragmas: choose by gens, then specialisations
 508     chk_pragmas a@(SpecialisedInstancePragma _ _) (SpecialisedInstancePragma _ _)
 509       = trace "not checking two SpecialisedInstancePragma pragmas!" (returnRn12 (wout a))
 510
 511     chk_pragmas other1 other2  -- oops, bad mismatch
 512       = pRAGMA_ERROR "instance pragmas" (wout other1) -- ToDo: msg
 513 \end{code}
 514
 515 %************************************************************************
 516 %*                                                                      *
 517 \subsection[SpecInstSigs-RnPass2]{Functions for @AbstractTypeSigs@}
 518 %*                                                                      *
 519 %************************************************************************
 520
 521 We don't make any effort to look for duplicate ``SPECIALIZE instance''
 522 pragmas. (Later??)
 523
 524 We do this by make \tr{cmp*} always return \tr{LT_}---then there's
 525 nothing for \tr{sel*} to do!
 526
 527 \begin{code}
 528 cmpSpecInstSigs
 529     :: ProtoNameSpecInstSig -> ProtoNameSpecInstSig -> TAG_
 530
 531 selSpecInstSigs :: ProtoNameSpecInstSig
 532                 -> ProtoNameSpecInstSig
 533                 -> Rn12M ProtoNameSpecInstSig
 534
 535 cmpSpecInstSigs a b = LT_
 536 selSpecInstSigs a b = panic "RnPass2:selSpecInstSigs"
 537 \end{code}
 538
 539 %************************************************************************
 540 %*                                                                      *
 541 \subsection{Functions for SigDecls}
 542 %*                                                                      *
 543 %************************************************************************
 544
 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.
 547
 548 \begin{code}
 549 cmpSig :: ProtoNameSig -> ProtoNameSig -> TAG_
 550
 551 cmpSig (Sig n1 _ _ _) (Sig n2 _ _ _) = cmpProtoName n1 n2
 552
 553 cmpSig _ _ = panic# "cmpSig (rename2)"
 554
 555 selSig :: ProtoNameSig -> ProtoNameSig -> Rn12M ProtoNameSig
 556
 557 selSig s1@(Sig n1 ty pragmas1 locn1) s2@(Sig n2 _ pragmas2 locn2)
 558   = selByBetterName "type signature"
 559         n1 pragmas1 locn1 s1
 560         n2 pragmas2 locn2 s2
 561         (\ p -> Sig n1 ty p locn1) -- w/out its pragmas
 562         chooser_Sig
 563 \end{code}
 564
 565 \begin{code}
 566 chooser_Sig wout_prags g1 l1 s1@(Sig n1 ty1 _ _) g2 l2 s2@(Sig n2 ty2 _ _)
 567   = case (cmpPolyType cmpProtoName ty1 ty2) of
 568       EQ_ ->
 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
 574 \end{code}
 575
 576 %************************************************************************
 577 %*                                                                      *
 578 \subsection{Help functions: selecting based on pragmas}
 579 %*                                                                      *
 580 %************************************************************************
 581
 582 \begin{code}
 583 selGenPragmas
 584         :: ProtoNameGenPragmas -> SrcLoc
 585         -> ProtoNameGenPragmas -> SrcLoc
 586         -> Rn12M ProtoNameGenPragmas
 587
 588 selGenPragmas NoGenPragmas _ b            _ = returnRn12 b
 589 selGenPragmas a            _ NoGenPragmas _ = returnRn12 a
 590
 591 selGenPragmas g1@(GenPragmas arity1 upd1 def1 strict1 unfold1 specs1) locn1
 592               g2@(GenPragmas arity2 upd2 def2 strict2 unfold2 specs2) locn2
 593
 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)
 601   where
 602     sel_arity Nothing     Nothing   = returnRn12 Nothing
 603     sel_arity a@(Just a1) (Just a2) = if a1 == a2
 604                                       then returnRn12 a
 605                                       else pRAGMA_ERROR "arity pragmas" a
 606     sel_arity a           _         = pRAGMA_ERROR "arity pragmas" a
 607
 608     -------
 609     sel_upd Nothing     Nothing   = returnRn12 Nothing
 610     sel_upd a@(Just u1) (Just u2) = if u1 == u2
 611                                     then returnRn12 a
 612                                     else pRAGMA_ERROR "update pragmas" a
 613     sel_upd a           _         = pRAGMA_ERROR "update pragmas" a
 614
 615     -------
 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
 619
 620     ----------
 621     sel_unfold NoImpUnfolding b              = returnRn12 b
 622     sel_unfold a              NoImpUnfolding = returnRn12 a
 623
 624     sel_unfold a@(ImpUnfolding _ c1) (ImpUnfolding _ c2)
 625       = if c1 `eqUfExpr` c2 -- very paranoid (and rightly so)
 626         then returnRn12 a
 627         else pprTrace "mismatched unfoldings:\n" (ppAbove (ppr PprDebug c1) (ppr PprDebug c2)) (
 628              returnRn12 NoImpUnfolding
 629              )
 630
 631     sel_unfold a@(ImpMagicUnfolding b) (ImpMagicUnfolding c)
 632       = if b == c then returnRn12 a else pRAGMA_ERROR "magic unfolding" a
 633
 634     sel_unfold a _ = pRAGMA_ERROR "unfolding pragmas" a
 635
 636     ----------
 637     sel_strict NoImpStrictness NoImpStrictness = returnRn12 NoImpStrictness
 638
 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)
 646
 647     sel_strict a _ = pRAGMA_ERROR "strictness pragmas" a
 648
 649     ---------
 650     sel_specs specs1 specs2
 651       = selSpecialisations specs1 locn1 specs2 locn2
 652 \end{code}
 653
 654 \begin{code}
 655 selNamePragmaPairs
 656         :: [(ProtoName, ProtoNameGenPragmas)] -> SrcLoc
 657         -> [(ProtoName, ProtoNameGenPragmas)] -> SrcLoc
 658         -> Rn12M [(ProtoName, ProtoNameGenPragmas)]
 659
 660 selNamePragmaPairs [] _ [] _ = returnRn12 []
 661 selNamePragmaPairs [] _ bs _ = returnRn12 bs
 662 selNamePragmaPairs as _ [] _ = returnRn12 as
 663
 664 selNamePragmaPairs ((name1, prags1) : pairs1) loc1
 665                    ((name2, prags2) : pairs2) loc2
 666
 667   = if not (name1 `eqProtoName` name2) then
 668         -- msg of any kind??? ToDo
 669         pRAGMA_ERROR "named pragmas" pairs1
 670     else
 671         selGenPragmas prags1 loc1 prags2 loc2       `thenRn12` \ new_prags ->
 672         selNamePragmaPairs pairs1 loc1 pairs2 loc2  `thenRn12` \ rest ->
 673         returnRn12 ( (name1, new_prags) : rest )
 674 \end{code}
 675
 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.
 678
 679 \begin{code}
 680 selSpecialisations
 681         :: [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)] -> SrcLoc
 682         -> [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)] -> SrcLoc
 683         -> Rn12M [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)]
 684
 685 selSpecialisations [] _ [] _ = returnRn12 []
 686 selSpecialisations [] _ bs _ = returnRn12 bs -- arguable ... ToDo?
 687 selSpecialisations as _ [] _ = returnRn12 as -- ditto
 688
 689 selSpecialisations all_specs1@((spec1, dicts1, prags1) : rest_specs1) loc1
 690                    all_specs2@((spec2, dicts2, prags2) : rest_specs2) loc2
 691
 692   = case (cmp_spec spec1 spec2) of
 693          LT_ -> selSpecialisations rest_specs1 loc1 all_specs2 loc2
 694                                         `thenRn12` \ rest ->
 695                 returnRn12 ( (spec1, dicts1, prags1) : rest )
 696
 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
 702                                         `thenRn12` \ rest ->
 703                 returnRn12 ( (spec1, dicts1, new_prags) : rest )
 704
 705          GT_ -> selSpecialisations all_specs1 loc1 rest_specs2 loc2
 706                                         `thenRn12` \ rest ->
 707                 returnRn12 ( (spec2, dicts2, prags2) : rest )
 708
 709 cmp_spec [] []                     = EQ_
 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
 713                                         xxx -> xxx
 714 cmp_spec (Nothing:xs) (Just t2:ys) = LT_
 715 cmp_spec (Just t1:xs) (Nothing:ys) = GT_
 716 \end{code}
 717
 718 %************************************************************************
 719 %*                                                                      *
 720 \subsection{Help functions: @uniquefy@ and @selByBetterName@}
 721 %*                                                                      *
 722 %************************************************************************
 723
 724 \begin{code}
 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
 730
 731 uniquefy mod cmp sel things
 732   = mapRn12 (check_group_consistency sel) grouped_things
 733   where
 734     grouped_things = equivClasses cmp things
 735
 736     check_group_consistency :: (a -> a -> Rn12M a)      -- Selection function
 737                             -> [a]                      -- things to be compared
 738                             -> Rn12M a
 739
 740     check_group_consistency sel [] = panic "RnPass2: runs produced an empty list"
 741     check_group_consistency sel (thing:things) = foldrRn12 sel thing things
 742 \end{code}
 743
 744 @selByBetterName@: There are two ways one thing can have a ``better
 745 name'' than another.
 746
 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@
 749 name, probably).
 750
 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.
 755
 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.
 758
 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
 761 as errors.
 762
 763 \begin{code}
 764 selByBetterName :: String   -- class/datatype/synonym (for error msg)
 765
 766                 -- 1st/2nd comparee name/pragmas + their things
 767                 -> ProtoName -> pragmas -> SrcLoc -> thing
 768                 -> ProtoName -> pragmas -> SrcLoc -> thing
 769
 770                 -- a thing without its pragmas
 771                 -> (pragmas -> thing)
 772
 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
 778
 779                 -> Rn12M thing          -- selected thing
 780
 781 selByBetterName dup_msg
 782                 pn1 pragmas1 locn1 thing1
 783                 pn2 pragmas2 locn2 thing2
 784                 thing_wout_pragmas
 785                 chooser
 786   = getModuleNameRn12   `thenRn12` \ mod_name ->
 787     let
 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)
 793
 794         dup_error = report_dup dup_msg pn1 locn1 pn2 locn2 thing1
 795     in
 796     case pn1 of
 797       Unk _  -> case pn2 of
 798                  Unk _  -> dup_error
 799                  _      -> if orig_modules_clash mod_name pn2
 800                             then dup_error
 801                             else choose_thing1
 802
 803       Prel _ -> case pn2 of
 804                  Unk _  -> if orig_modules_clash mod_name pn1
 805                            then dup_error
 806                            else choose_thing2
 807                  _      -> check_n_choose
 808
 809       Imp om1 _ im1 _ -> -- we're gonna check `informant module' info...
 810         case pn2 of
 811           Unk _           -> if orig_modules_clash mod_name pn1
 812                              then dup_error
 813                              else choose_thing2
 814           Prel _          -> check_n_choose
 815           Imp om2 _ im2 _
 816             -> let
 817                    is_elem = isIn "selByBetterName"
 818
 819                    name1_claims_orig = om1 `is_elem` im1 && not (_NULL_ om1)
 820                    name2_claims_orig = om2 `is_elem` im2 && not (_NULL_ om2)
 821                in
 822                if name1_claims_orig
 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
 825   where
 826     chk_eq if_OK
 827       = if not (eqProtoName pn1 pn2) && eqByLocalName pn1 pn2
 828         then report_dup dup_msg pn1 locn1 pn2 locn2 thing1
 829         else if_OK
 830
 831     orig_modules_clash this_module pn
 832       = case (getOrigName pn) of { (that_module, _) ->
 833         not (this_module == that_module) }
 834
 835 report_dup dup_msg pn1 locn1 pn2 locn2 thing
 836   = addErrRn12 err_msg `thenRn12` \ _ ->
 837     returnRn12 thing
 838   where
 839     err_msg = dupNamesErr dup_msg [(pn1,locn1), (pn2,locn2)]
 840
 841 pRAGMA_ERROR :: String -> a -> Rn12M a
 842 pRAGMA_ERROR msg x
 843   = addErrRn12 (\ sty -> ppStr ("PRAGMA ERROR:"++msg)) `thenRn12` \ _ ->
 844     returnRn12 x
 845 \end{code}