ghc/compiler/rename/RnPass3.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[RnPass3]{Third of the renaming passes}
   5
   6 The business of this pass is to:
   7 \begin{itemize}
   8 \item   find all the things declared at top level,
   9 \item   assign uniques to them
  10 \item return an association list mapping their @ProtoName@s to
  11         freshly-minted @Names@ for them.
  12 \end{itemize}
  13
  14 No attempt is made to discover whether the same thing is declared
  15 twice: that is up to the caller to sort out.
  16
  17 \begin{code}
  18 #include "HsVersions.h"
  19
  20 module RnPass3 (
  21         rnModule3,
  22         initRn3, Rn3M(..)  -- re-exported from monad
  23
  24         -- for completeness
  25     ) where
  26
  27 import Ubiq{-uitous-}
  28
  29 import RnMonad3
  30 import HsSyn
  31 import RdrHsSyn
  32
  33 import Bag              ( emptyBag, listToBag, unionBags, unionManyBags,
  34                           unitBag, snocBag, elemBag, bagToList, Bag
  35                         )
  36 import ErrUtils
  37 import HsPragmas        ( DataPragmas(..) )
  38 import Name             ( Name(..) )
  39 import NameTypes        ( fromPrelude, FullName{-instances-} )
  40 import Pretty
  41 import ProtoName        ( cmpByLocalName, ProtoName(..) )
  42 import RnUtils          ( mkGlobalNameFun,
  43                           GlobalNameMappers(..), GlobalNameMapper(..),
  44                           PreludeNameMappers(..), PreludeNameMapper(..),
  45                           dupNamesErr
  46                         )
  47 import SrcLoc           ( SrcLoc{-instance-} )
  48 import Util             ( isIn, removeDups, cmpPString, panic )
  49 \end{code}
  50
  51 *********************************************************
  52 *                                                       *
  53 \subsection{Type declarations}
  54 *                                                       *
  55 *********************************************************
  56
  57 \begin{code}
  58 type BagAssoc       = Bag (ProtoName, Name)     -- Bag version
  59 type NameSpaceAssoc = [(ProtoName, Name)]       -- List version
  60 \end{code}
  61
  62
  63 *********************************************************
  64 *                                                       *
  65 \subsection{Main function: @rnModule3@}
  66 *                                                       *
  67 *********************************************************
  68
  69 \begin{code}
  70 rnModule3 :: PreludeNameMappers
  71           -> Bag FAST_STRING    -- list of imported module names
  72           -> ProtoNameHsModule
  73           -> Rn3M ( NameSpaceAssoc, NameSpaceAssoc,
  74                     GlobalNameMapper,  GlobalNameMapper,
  75                     Bag Error )
  76
  77 rnModule3 pnfs@(val_pnf, tc_pnf) imported_mod_names
  78           (HsModule mod_name exports imports _ ty_decls _ class_decls
  79             inst_decls _ _ binds sigs _)
  80
  81   = putInfoDownM3 {- ???pnfs -} mod_name exports (
  82
  83     doTyDecls3 ty_decls         `thenRn3` \ (constrs, tycons) ->
  84     doClassDecls3 class_decls   `thenRn3` \ (ops, classes) ->
  85     doBinds3 binds              `thenRn3` \ val_binds ->
  86     doIntSigs3 sigs             `thenRn3` \ val_sigs ->
  87
  88     let val_namespace   = constrs `unionBags` ops `unionBags` val_binds
  89                                   `unionBags` val_sigs
  90         tc_namespace    = tycons `unionBags` classes
  91
  92         (var_alist, var_dup_errs) = deal_with_dups "variable" val_pnf (bagToList val_namespace)
  93         (tc_alist, tc_dup_errs)   = deal_with_dups "type or class" tc_pnf (bagToList tc_namespace)
  94         v_gnf  = mkGlobalNameFun mod_name val_pnf var_alist
  95         tc_gnf = mkGlobalNameFun mod_name tc_pnf  tc_alist
  96     in
  97
  98     verifyExports v_gnf tc_gnf (imported_mod_names `snocBag` mod_name) exports
  99                                         `thenRn3` \ export_errs ->
 100     verifyImports v_gnf tc_gnf imports  `thenRn3` \ import_errs ->
 101
 102     returnRn3 ( var_alist, tc_alist,
 103                 v_gnf, tc_gnf,
 104                 var_dup_errs `unionBags` tc_dup_errs `unionBags`
 105                 export_errs  `unionBags` import_errs
 106     ))
 107   where
 108     deal_with_dups :: String -> PreludeNameMapper -> NameSpaceAssoc
 109                    -> (NameSpaceAssoc, Bag Error)
 110
 111     deal_with_dups kind_str pnf alist
 112       = (goodies,
 113          listToBag (map mk_dup_err dup_lists) `unionBags`
 114          listToBag (map mk_prel_dup_err prel_dups)
 115         )
 116       where
 117         goodies   :: [(ProtoName,Name)]         --NameSpaceAssoc
 118         dup_lists :: [[(ProtoName, Name)]]
 119
 120         -- Find all the names which are defined twice.
 121         -- By "name" here, we mean "string"; that is, we are looking
 122         -- for places where two strings are bound to different Names
 123         -- in the top-level scope of this module.
 124
 125         (singles, dup_lists) = removeDups cmp alist
 126         -- We want to compare their *local* names; the removeDups thing
 127         -- is checking for whether two objects have the same local name.
 128         cmp (a, _) (b, _) = cmpByLocalName a b
 129
 130         -- Anything in alist with a Unk name is defined right here in
 131         -- this module; hence, it should not be a prelude name.  We
 132         -- need to check this separately, because the prelude is
 133         -- imported only implicitly, via the PrelNameFuns argument
 134
 135         (goodies, prel_dups) = if fromPrelude mod_name then
 136                                  (singles, [])  -- Compiling the prelude, so ignore this check
 137                                else
 138                                  partition local_def_of_prelude_thing singles
 139
 140         local_def_of_prelude_thing (Unk s, _)
 141           = case pnf s of
 142               Just _  -> False          -- Eek!  It's a prelude name
 143               Nothing -> True           -- It isn't; all is ok
 144         local_def_of_prelude_thing other = True
 145
 146         mk_dup_err :: [(ProtoName, Name)] -> Error
 147         mk_dup_err dups_of_name
 148           = let
 149                 dup_pnames_w_src_loc = [ (pn, getSrcLoc name) | (pn,name) <- dups_of_name ]
 150             in
 151             dupNamesErr kind_str dup_pnames_w_src_loc
 152
 153         -- This module defines a prelude thing
 154         mk_prel_dup_err :: (ProtoName, Name) -> Error
 155         mk_prel_dup_err (pn, name)
 156           = dupPreludeNameErr kind_str (pn, getSrcLoc name)
 157 \end{code}
 158
 159 *********************************************************
 160 *                                                       *
 161 \subsection{Type and class declarations}
 162 *                                                       *
 163 *********************************************************
 164
 165 \begin{code}
 166 doTyDecls3 :: [ProtoNameTyDecl] -> Rn3M (BagAssoc, BagAssoc)
 167
 168 doTyDecls3 [] = returnRn3 (emptyBag, emptyBag)
 169
 170 doTyDecls3 (tyd:tyds)
 171   = andRn3 combiner (do_decl tyd) (doTyDecls3 tyds)
 172   where
 173     combiner (cons1, tycons1) (cons2, tycons2)
 174       = (cons1 `unionBags` cons2, tycons1 `unionBags` tycons2)
 175
 176     do_decl (TyData context tycon tyvars condecls _ pragmas src_loc)
 177       = newFullNameM3 tycon src_loc True{-tycon-ish-} Nothing
 178                                         `thenRn3` \ (uniq, tycon_name) ->
 179         let
 180             exp_flag = getExportFlag tycon_name
 181                 -- we want to force all data cons to have the very
 182                 -- same export flag as their type constructor
 183         in
 184         doConDecls3 False{-not invisibles-} exp_flag condecls `thenRn3` \ data_cons ->
 185         do_data_pragmas exp_flag pragmas                      `thenRn3` \ pragma_data_cons ->
 186         returnRn3 (data_cons `unionBags` pragma_data_cons,
 187                    unitBag (tycon, TyConName uniq tycon_name (length tyvars)
 188                                         True -- indicates data/newtype tycon
 189                                         [ c | (_,c) <- bagToList data_cons ]))
 190
 191     do_decl (TyNew context tycon tyvars condecl _ pragmas src_loc)
 192       = newFullNameM3 tycon src_loc True{-tycon-ish-} Nothing
 193                                         `thenRn3` \ (uniq, tycon_name) ->
 194         let
 195             exp_flag = getExportFlag tycon_name
 196                 -- we want to force all data cons to have the very
 197                 -- same export flag as their type constructor
 198         in
 199         doConDecls3 False{-not invisibles-} exp_flag condecl  `thenRn3` \ data_con ->
 200         do_data_pragmas exp_flag pragmas                      `thenRn3` \ pragma_data_con ->
 201         returnRn3 (data_con `unionBags` pragma_data_con,
 202                    unitBag (tycon, TyConName uniq tycon_name (length tyvars)
 203                                         True -- indicates data/newtype tycon
 204                                         [ c | (_,c) <- bagToList data_con ]))
 205
 206     do_decl (TySynonym tycon tyvars monoty src_loc)
 207       = newFullNameM3 tycon src_loc True{-tycon-ish-} Nothing
 208                                         `thenRn3` \ (uniq, tycon_name) ->
 209         returnRn3 (emptyBag,
 210                    unitBag (tycon, TyConName uniq tycon_name (length tyvars) False bottom))
 211                                         -- Flase indicates type tycon
 212       where
 213         bottom = panic "do_decl: data cons on synonym?"
 214
 215     do_data_pragmas exp_flag (DataPragmas con_decls specs)
 216       = doConDecls3 True{-invisibles-} exp_flag con_decls
 217 \end{code}
 218
 219 \begin{code}
 220 doConDecls3 :: Bool                 -- True <=> mk invisible FullNames
 221             -> ExportFlag           -- Export flag of the TyCon; we want
 222                                     -- to force its use.
 223             -> [ProtoNameConDecl]
 224             -> Rn3M BagAssoc
 225
 226 doConDecls3 _ _ [] = returnRn3 emptyBag
 227
 228 doConDecls3 want_invisibles exp_flag (cd:cds)
 229   = andRn3 unionBags (do_decl cd) (doConDecls3 want_invisibles exp_flag cds)
 230   where
 231     mk_name = if want_invisibles then newInvisibleNameM3 else newFullNameM3
 232
 233     do_decl (ConDecl con tys src_loc)
 234       = mk_name con src_loc True{-tycon-ish-} (Just exp_flag) `thenRn3` \ (uniq, con_name) ->
 235         returnRn3 (unitBag (con, ValName uniq con_name))
 236     do_decl (ConOpDecl ty1 op ty2 src_loc)
 237       = mk_name op src_loc True{-tycon-ish-} (Just exp_flag)  `thenRn3` \ (uniq, con_name) ->
 238         returnRn3 (unitBag (op, ValName uniq con_name))
 239     do_decl (NewConDecl con ty src_loc)
 240       = mk_name con src_loc True{-tycon-ish-} (Just exp_flag) `thenRn3` \ (uniq, con_name) ->
 241         returnRn3 (unitBag (con, ValName uniq con_name))
 242     do_decl (RecConDecl con fields src_loc)
 243       = _trace "doConDecls3:RecConDecl:nothing for fields\n" $
 244         mk_name con src_loc True{-tycon-ish-} (Just exp_flag) `thenRn3` \ (uniq, con_name) ->
 245         returnRn3 (unitBag (con, ValName uniq con_name))
 246 \end{code}
 247
 248
 249 @doClassDecls3@ uses the `name function' to map local class names into
 250 original names, calling @doClassOps3@ to do the same for the
 251 class operations. @doClassDecls3@ is used to process module
 252 class declarations.
 253
 254 \begin{code}
 255 doClassDecls3 :: [ProtoNameClassDecl] -> Rn3M (BagAssoc, BagAssoc)
 256
 257 doClassDecls3 [] = returnRn3 (emptyBag, emptyBag)
 258
 259 doClassDecls3 (cd:cds)
 260   = andRn3 combiner (do_decl cd) (doClassDecls3 cds)
 261   where
 262     combiner (ops1, classes1) (ops2, classes2)
 263       = (ops1 `unionBags` ops2, classes1 `unionBags` classes2)
 264
 265     do_decl (ClassDecl context cname@(Prel c) tyvar sigs defaults pragmas src_loc)
 266       = doClassOps3 c 1 sigs    `thenRn3` \ (_, ops) ->
 267         returnRn3 (ops, unitBag (cname, c))
 268
 269     do_decl (ClassDecl context cname tyvar sigs defaults pragmas src_loc)
 270       = newFullNameM3 cname src_loc True{-tycon-ish-} Nothing
 271                                         `thenRn3` \ (uniq, class_name) ->
 272         fixRn3 ( \ ~(clas_ops,_) ->
 273             let
 274                 class_Name = ClassName uniq class_name
 275                                         [ o | (_,o) <- bagToList clas_ops ]
 276             in
 277             doClassOps3 class_Name 1 sigs   `thenRn3` \ (_, ops) ->
 278             returnRn3 (ops, class_Name)
 279         )                               `thenRn3` \ (ops, class_Name) ->
 280
 281         returnRn3 (ops, unitBag (cname, class_Name))
 282 \end{code}
 283
 284 We stitch on a class-op tag to each class operation.  They are guaranteed
 285 to be done in left-to-right order.
 286
 287 \begin{code}
 288 doClassOps3 :: Name{-class-} -> Int -> [ProtoNameSig] -> Rn3M (Int, BagAssoc)
 289
 290 doClassOps3 clas tag [] = returnRn3 (tag, emptyBag)
 291
 292 doClassOps3 clas tag (sig:rest)
 293   = do_op                 sig   `thenRn3` \ (tag1, bag1) ->
 294     doClassOps3 clas tag1 rest  `thenRn3` \ (tagr, bagr) ->
 295     returnRn3 (tagr, bag1 `unionBags` bagr)
 296   where
 297 {- LATER: NB: OtherVal is a Name, not a ProtoName
 298     do_op (ClassOpSig op@(OtherVal uniq name) ty pragma src_loc)
 299       = -- A classop whose unique is pre-ordained, so the type checker
 300         -- can look it up easily
 301         let
 302             op_name = ClassOpName uniq clas (snd (getOrigName name)) tag
 303         in
 304         returnRn3 (tag+1, unitBag (op, op_name))
 305 -}
 306
 307     do_op (ClassOpSig op ty pragma src_loc)
 308       = newFullNameM3 op src_loc False{-not tyconish-} Nothing `thenRn3` \ (uniq, _) ->
 309         let
 310             op_name = ClassOpName uniq clas (get_str op) tag
 311         in
 312         returnRn3 (tag+1, unitBag (op, op_name))
 313       where
 314         -- A rather yukky function to get the original name out of a
 315         -- class operation.  The "snd (getOrigName ...)" in the other
 316         -- ClassOpSig case does the corresponding yukky thing.
 317         get_str :: ProtoName -> FAST_STRING
 318         get_str (Unk s)       = s
 319         get_str (Qunk _ s)    = s
 320         get_str (Imp _ d _ _) = d
 321 \end{code}
 322
 323 Remember, interface signatures don't have user-pragmas, etc., in them.
 324 \begin{code}
 325 doIntSigs3 :: [ProtoNameSig] -> Rn3M BagAssoc
 326
 327 doIntSigs3 [] = returnRn3 emptyBag
 328
 329 doIntSigs3 (s:ss)
 330   = andRn3 unionBags (do_sig s) (doIntSigs3 ss)
 331   where
 332     do_sig (Sig v ty pragma src_loc)
 333       = newFullNameM3 v src_loc False{-distinctly untycon-ish-} Nothing
 334                                              `thenRn3` \ (uniq, v_fname) ->
 335         returnRn3 (unitBag (v, ValName uniq v_fname))
 336 \end{code}
 337
 338 *********************************************************
 339 *                                                       *
 340 \subsection{Bindings}
 341 *                                                       *
 342 *********************************************************
 343
 344 \begin{code}
 345 doBinds3 :: ProtoNameHsBinds -> Rn3M BagAssoc
 346
 347 doBinds3 EmptyBinds = returnRn3 emptyBag
 348
 349 doBinds3 (ThenBinds binds1 binds2)
 350   = andRn3 unionBags (doBinds3 binds1) (doBinds3 binds2)
 351
 352 doBinds3 (SingleBind bind)    = doBind3 bind
 353
 354 doBinds3 (BindWith bind sigs) = doBind3 bind
 355 \end{code}
 356
 357 \begin{code}
 358 doBind3 :: ProtoNameBind -> Rn3M BagAssoc
 359 doBind3 EmptyBind          = returnRn3 emptyBag
 360 doBind3 (NonRecBind mbind) = doMBinds3 mbind
 361 doBind3 (RecBind mbind)    = doMBinds3 mbind
 362
 363 doMBinds3 :: ProtoNameMonoBinds -> Rn3M BagAssoc
 364
 365 doMBinds3 EmptyMonoBinds                         = returnRn3 emptyBag
 366 doMBinds3 (PatMonoBind pat grhss_and_binds locn) = doPat3 locn pat
 367 doMBinds3 (FunMonoBind p_name _ locn)            = doTopLevName locn p_name
 368
 369 doMBinds3 (AndMonoBinds mbinds1 mbinds2)
 370   = andRn3 unionBags (doMBinds3 mbinds1) (doMBinds3 mbinds2)
 371 \end{code}
 372
 373 Fold over a list of patterns:
 374 \begin{code}
 375 doPats3 locn [] = returnRn3 emptyBag
 376 doPats3 locn (pat:pats)
 377   = andRn3 unionBags (doPat3 locn pat) (doPats3 locn pats)
 378 \end{code}
 379
 380 \begin{code}
 381 doPat3 :: SrcLoc -> ProtoNamePat -> Rn3M BagAssoc
 382
 383 doPat3 locn WildPatIn           = returnRn3 emptyBag
 384 doPat3 locn (LitPatIn _)        = returnRn3 emptyBag
 385 doPat3 locn (LazyPatIn pat)     = doPat3 locn pat
 386 doPat3 locn (VarPatIn n)        = doTopLevName locn n
 387 doPat3 locn (ListPatIn pats)    = doPats3 locn pats
 388 doPat3 locn (TuplePatIn pats)   = doPats3 locn pats
 389
 390 doPat3 locn (AsPatIn p_name pat)
 391   = andRn3 unionBags (doTopLevName locn p_name) (doPat3 locn pat)
 392
 393 doPat3 locn (ConPatIn name pats) = doPats3 locn pats
 394
 395 doPat3 locn (ConOpPatIn pat1 name pat2)
 396   = andRn3 unionBags (doPat3 locn pat1) (doPat3 locn pat2)
 397 \end{code}
 398
 399 \begin{code}
 400 doTopLevName :: SrcLoc -> ProtoName -> Rn3M BagAssoc
 401
 402 doTopLevName locn pn
 403   = newFullNameM3 pn locn False{-un-tycon-ish-} Nothing `thenRn3` \ (uniq, name) ->
 404     returnRn3 (unitBag (pn, ValName uniq name))
 405 \end{code}
 406
 407 Have to check that export/imports lists aren't too drug-crazed.
 408
 409 \begin{code}
 410 verifyExports :: GlobalNameMapper -> GlobalNameMapper
 411               -> Bag FAST_STRING -- module names that might appear
 412                                  -- in an export list; includes the
 413                                  -- name of this module
 414               -> Maybe [IE ProtoName]   -- export list
 415               -> Rn3M (Bag Error)
 416
 417 verifyExports _ _ _ Nothing{-no export list-} = returnRn3 emptyBag
 418
 419 verifyExports v_gnf tc_gnf imported_mod_names export_list@(Just exports)
 420   = mapRn3 verify exports       `thenRn3` \ errs ->
 421     chk_exp_dups  export_list   `thenRn3` \ dup_errs ->
 422     returnRn3 (unionManyBags (errs ++ dup_errs))
 423   where
 424     ok             = returnRn3 emptyBag
 425     naughty nm msg = returnRn3 (unitBag (badExportNameErr (_UNPK_ nm) msg))
 426     undef_name nm  = naughty nm "is not defined."
 427     dup_name (nm:_)= naughty nm "occurs more than once."
 428
 429     undef_name :: FAST_STRING -> Rn3M (Bag Error)
 430     dup_name :: [FAST_STRING] -> Rn3M (Bag Error)
 431
 432     ----------------
 433     chk_exp_dups :: Maybe [IE ProtoName] -> Rn3M [Bag Error]
 434
 435     chk_exp_dups exports
 436       = let
 437             export_strs = [ nm | (nm, _) <- fst (getRawExportees exports) ]
 438             (_, dup_lists) = removeDups cmpByLocalName{-????-} export_strs
 439         in
 440         mapRn3 dup_name [map getOccurrenceName dl | dl <- dup_lists]
 441
 442     ---------------- the more serious checking
 443     verify :: IE ProtoName -> Rn3M (Bag Error)
 444
 445     verify (IEVar v)
 446       = case (v_gnf v) of { Nothing -> undef_name (getOccurrenceName v); _ -> ok }
 447
 448     verify (IEModuleContents mod)
 449       = if not (mod `elemBag` imported_mod_names) then undef_name mod else ok
 450
 451     verify (IEThingAbs tc)
 452       = case (tc_gnf tc) of
 453           Nothing -> undef_name (getOccurrenceName tc)
 454           Just nm -> let
 455                         naughty_tc = naughty (getOccurrenceName tc)
 456                      in
 457                      case nm of
 458                        TyConName _ _ _ False{-syn-} _
 459                          -> naughty_tc "must be exported with a `(..)' -- it's a synonym."
 460
 461                        ClassName _ _ _
 462                          -> naughty_tc "cannot be exported \"abstractly\" (it's a class)."
 463                        _ -> ok
 464
 465     verify (IEThingAll tc)
 466       = case (tc_gnf tc) of
 467           Nothing -> undef_name (getOccurrenceName tc)
 468           Just nm -> let
 469                         naughty_tc = naughty (getOccurrenceName tc)
 470                      in
 471                      case nm of
 472                        TyConName _ _ _ True{-data or newtype-} [{-no cons-}]
 473                          -> naughty_tc "can't be exported with a `(..)' -- it was imported abstractly."
 474                        _ -> ok
 475
 476 {- OLD:
 477     verify (IEConWithCons tc cs)
 478       = case (tc_gnf tc) of
 479           Nothing -> undef_name tc
 480           Just nm -> mapRn3 verify (map IEVar cs) `thenRn3` \ errs ->
 481                      returnRn3 (unionManyBags errs)
 482                      -- ToDo: turgid checking which we don't care about (WDP 94/10)
 483
 484     verify (IEClsWithOps c ms)
 485       = case (tc_gnf c) of
 486           Nothing -> undef_name c
 487           Just  _ -> mapRn3 verify (map IEVar ms) `thenRn3` \ errs ->
 488                      returnRn3 (unionManyBags errs)
 489                      -- ToDo: turgid checking which we don't care about (WDP 94/10)
 490 -}
 491 \end{code}
 492
 493 Note: we're not too particular about whether something mentioned in an
 494 import list is in {\em that} interface... (ToDo? Probably not.)
 495
 496 \begin{code}
 497 verifyImports :: GlobalNameMapper -> GlobalNameMapper
 498               -> [ProtoNameImportedInterface]
 499               -> Rn3M (Bag Error)
 500
 501 verifyImports v_gnf tc_gnf imports
 502   = mapRn3 chk_one (map collect imports) `thenRn3` \ errs ->
 503     returnRn3 (unionManyBags errs)
 504   where
 505     -- collect: name/locn, import list
 506
 507     collect (ImportMod iff qual asmod details)
 508       = (iface iff, imp_list, hide_list)
 509       where
 510         (imp_list, hide_list)
 511           = case details of
 512               Nothing                    -> ([],  [])
 513               Just (True{-hidden-}, ies) -> ([],  ies)
 514               Just (_ {-unhidden-}, ies) -> (ies, [])
 515
 516     ------------
 517     iface (Interface name _ _ _ _ _ _ locn) = (name, locn)
 518
 519     ------------
 520     chk_one :: ((FAST_STRING, SrcLoc), [IE ProtoName], [IE ProtoName])
 521             -> Rn3M (Bag Error)
 522
 523     chk_one ((mod_name, locn), import_list, hide_list)
 524       = mapRn3 verify import_list   `thenRn3` \ errs1 ->
 525         chk_imp_dups  import_list   `thenRn3` \ dup_errs ->
 526         -- ToDo: we could check the hiding list more carefully
 527         chk_imp_dups  hide_list     `thenRn3` \ dup_errs2 ->
 528         returnRn3 (unionManyBags (errs1 ++ dup_errs ++ dup_errs2))
 529       where
 530         ok                = returnRn3 emptyBag
 531         naughty nm msg    = returnRn3 (unitBag (badImportNameErr (_UNPK_ mod_name) (_UNPK_ nm) msg locn))
 532         undef_name nm     = naughty nm "is not defined."
 533         dup_name (nm:_)   = naughty nm "occurs more than once."
 534
 535         undef_name :: FAST_STRING -> Rn3M (Bag Error)
 536         dup_name :: [FAST_STRING] -> Rn3M (Bag Error)
 537
 538         ----------------
 539         chk_imp_dups imports
 540           = let
 541                 import_strs = getRawImportees imports
 542                 (_, dup_lists) = removeDups _CMP_STRING_ import_strs
 543             in
 544             mapRn3 dup_name dup_lists
 545
 546         ----------------
 547         verify :: IE ProtoName -> Rn3M (Bag Error)
 548
 549         verify (IEVar v)
 550           = case (v_gnf v) of { Nothing -> undef_name (getOccurrenceName v); _ -> ok }
 551
 552         verify (IEThingAbs tc)
 553           = case (tc_gnf tc) of
 554               Nothing -> undef_name (getOccurrenceName tc)
 555               Just nm -> let
 556                             naughty_tc = naughty (getOccurrenceName tc)
 557                          in
 558                          case nm of
 559                            TyConName _ _ _ False{-syn-} _
 560                              -> naughty_tc "must be imported with a `(..)' -- it's a synonym."
 561                            ClassName _ _ _
 562                              -> naughty_tc "cannot be imported \"abstractly\" (it's a class)."
 563                            _ -> ok
 564
 565         verify (IEThingAll tc)
 566           = case (tc_gnf tc) of
 567               Nothing -> undef_name (getOccurrenceName tc)
 568               Just nm -> let
 569                             naughty_tc = naughty (getOccurrenceName tc)
 570                          in
 571                          case nm of
 572                            TyConName _ _ _ True{-data or newtype-} [{-no cons-}]
 573                              -> naughty_tc "can't be imported with a `(..)' -- the interface says it's abstract."
 574                            _ -> ok
 575
 576 {- OLD:
 577         verify (IEConWithCons tc cs)
 578           = case (tc_gnf tc) of
 579               Nothing -> undef_name (getOccurrenceName tc)
 580               Just nm -> mapRn3 verify (map IEVar cs) `thenRn3` \ errs ->
 581                          returnRn3 (unionManyBags errs)
 582                          -- One could add a great wad of tedious checking
 583                          -- here, but I am too lazy to do so.  WDP 94/10
 584
 585         verify (IEClsWithOps c ms)
 586           = case (tc_gnf c) of
 587               Nothing -> undef_name (getOccurrenceName c)
 588               Just  _ -> mapRn3 verify (map IEVar ms) `thenRn3` \ errs ->
 589                          returnRn3 (unionManyBags errs)
 590                          -- Ditto about tedious checking.  WDP 94/10
 591 -}
 592 \end{code}
 593
 594 %************************************************************************
 595 %*                                                                      *
 596 \subsection{Error messages}
 597 %*                                                                      *
 598 %************************************************************************
 599
 600 \begin{code}
 601 badExportNameErr name whats_wrong
 602   = dontAddErrLoc
 603         "Error in the export list" ( \ sty ->
 604     ppBesides [ppChar '`', ppStr name, ppStr "' ", ppStr whats_wrong] )
 605
 606 ------------------------------------------
 607 badImportNameErr mod name whats_wrong locn
 608   = addErrLoc locn
 609         ("Error in an import list for the module `"++mod++"'") ( \ sty ->
 610     ppBesides [ppChar '`', ppStr name, ppStr "' ", ppStr whats_wrong] )
 611
 612 ----------------------------
 613 -- dupNamesErr: from RnUtils
 614
 615 --------------------------------------
 616 dupPreludeNameErr descriptor (nm, locn)
 617   = addShortErrLocLine locn ( \ sty ->
 618     ppBesides [ ppStr "A conflict with a Prelude ", ppStr descriptor,
 619                 ppStr ": ", ppr sty nm ])
 620 \end{code}