ghc/compiler/rename/RnNames.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[RnNames]{Extracting imported and top-level names in scope}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module RnNames (
  10         getGlobalNames,
  11         SYN_IE(GlobalNameInfo)
  12     ) where
  13
  14 import PreludeGlaST     ( SYN_IE(MutableVar) )
  15
  16 IMP_Ubiq()
  17
  18 import HsSyn
  19 import RdrHsSyn
  20 import RnHsSyn
  21
  22 import RnMonad
  23 import RnIfaces         ( IfaceCache, cachedIface, cachedDecl, CachingResult(..) )
  24 import RnUtils          ( SYN_IE(RnEnv), emptyRnEnv, initRnEnv, extendGlobalRnEnv,
  25                           lubExportFlag, qualNameErr, dupNamesErr, pprRnEnv
  26                         )
  27 import ParseUtils       ( ParsedIface(..), RdrIfaceDecl(..), ExportsMap(..), RdrIfaceInst )
  28
  29
  30 import Bag              ( emptyBag, unitBag, consBag, snocBag, unionBags,
  31                           unionManyBags, mapBag, foldBag, filterBag, listToBag, bagToList )
  32 import CmdLineOpts      ( opt_NoImplicitPrelude, opt_CompilingGhcInternals )
  33 import ErrUtils         ( SYN_IE(Error), SYN_IE(Warning), addErrLoc, addShortErrLocLine, addShortWarnLocLine )
  34 import FiniteMap        ( emptyFM, addToFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, keysFM{-ToDo:rm-}, FiniteMap )
  35 import Id               ( GenId )
  36 import Maybes           ( maybeToBool, catMaybes, MaybeErr(..) )
  37 import Name             ( RdrName(..), Name, isQual, mkTopLevName, mkWiredInName, origName,
  38                           nameOf, qualToOrigName, mkImportedName,
  39                           nameExportFlag, nameImportFlag,
  40                           getLocalName, getSrcLoc, getImpLocs,
  41                           moduleNamePair, pprNonSym,
  42                           isLexCon, isLexSpecialSym, ExportFlag(..), OrigName(..)
  43                         )
  44 import PrelInfo         ( SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
  45 import PrelMods         ( pRELUDE, gHC_BUILTINS, modulesWithBuiltins )
  46 import Pretty
  47 import SrcLoc           ( SrcLoc, mkBuiltinSrcLoc )
  48 import TyCon            ( tyConDataCons )
  49 import UniqFM           ( emptyUFM, addListToUFM_C, lookupUFM )
  50 import UniqSupply       ( splitUniqSupply )
  51 import Util             ( isIn, assoc, cmpPString, sortLt, removeDups,
  52                           equivClasses, panic, assertPanic, pprPanic{-ToDo:rm-}, pprTrace{-ToDo:rm-}
  53                         )
  54 import PprStyle --ToDo:rm
  55 \end{code}
  56
  57 \begin{code}
  58 type GlobalNameInfo = (BuiltinNames,
  59                        BuiltinKeys,
  60                        Name -> ExportFlag,      -- export flag
  61                        Name -> [RdrName])       -- occurrence names
  62                        -- NB: both of the functions are in a *knot* and
  63                        -- must be tugged on oh-so-gently...
  64
  65 type RnM_Info s r = RnMonad GlobalNameInfo s r
  66
  67 getGlobalNames ::
  68            IfaceCache
  69         -> GlobalNameInfo
  70         -> UniqSupply
  71         -> RdrNameHsModule
  72         -> IO (RnEnv,
  73                [Module],                -- directly imported modules
  74                Bag (Module,RnName),     -- unqualified imports from module
  75                Bag RenamedFixityDecl,   -- imported fixity decls
  76                Bag Error,
  77                Bag Warning)
  78
  79 getGlobalNames iface_cache info us
  80                (HsModule mod _ _ imports _ ty_decls _ cls_decls _ _ _ binds _ _)
  81   = let
  82         (us1, us2) = splitUniqSupply us
  83     in
  84     case initRn True mod emptyRnEnv us1
  85                 (setExtraRn info $
  86                  getSourceNames ty_decls cls_decls binds)
  87     of { ((src_vals, src_tcs), src_errs, src_warns) ->
  88
  89     doImportDecls iface_cache info us2 imports  >>=
  90         \ (imp_vals, imp_tcs, imp_mods, unqual_imps, imp_fixes, imp_errs, imp_warns) ->
  91
  92     let
  93         unqual_vals = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_vals)
  94         unqual_tcs  = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_tcs)
  95
  96         (src_env, src_dups) = extendGlobalRnEnv initRnEnv unqual_vals unqual_tcs
  97         (all_env, imp_dups) = extendGlobalRnEnv src_env (bagToList imp_vals) (bagToList imp_tcs)
  98
  99         -- remove dups of the same imported thing
 100         diff_imp_dups = filterBag diff_orig imp_dups
 101         diff_orig (_,rn1,rn2) = origName "diff_orig" rn1 /= origName "diff_orig" rn2
 102
 103         all_dups = bagToList (src_dups `unionBags` diff_imp_dups)
 104         dup_errs = map dup_err (equivClasses cmp_rdr all_dups)
 105         cmp_rdr (rdr1,_,_) (rdr2,_,_) = cmp rdr1 rdr2
 106         dup_err ((rdr,rn1,rn2):rest) = globalDupNamesErr rdr (rn1:rn2: [rn|(_,_,rn)<-rest])
 107
 108         all_errs  = src_errs  `unionBags` imp_errs `unionBags` listToBag dup_errs
 109         all_warns = src_warns `unionBags` imp_warns
 110     in
 111 --    pprTrace "initRnEnv:" (pprRnEnv PprDebug initRnEnv) $
 112 --    pprTrace "src_env:"   (pprRnEnv PprDebug src_env) $
 113 --    pprTrace "all_env:"   (pprRnEnv PprDebug all_env) $
 114     return (all_env, imp_mods, unqual_imps, imp_fixes, all_errs, all_warns) }
 115 \end{code}
 116
 117 *********************************************************
 118 *                                                       *
 119 \subsection{Top-level source names}
 120 *                                                       *
 121 *********************************************************
 122
 123 \begin{code}
 124 getSourceNames ::                       -- Collects global *binders* (not uses)
 125            [RdrNameTyDecl]
 126         -> [RdrNameClassDecl]
 127         -> RdrNameHsBinds
 128         -> RnM_Info s (Bag RnName,      -- values
 129                        Bag RnName)      -- tycons/classes
 130
 131 getSourceNames ty_decls cls_decls binds
 132   = mapAndUnzip3Rn getTyDeclNames ty_decls      `thenRn` \ (tycon_s, constrs_s, fields_s) ->
 133     mapAndUnzipRn  getClassNames cls_decls      `thenRn` \ (cls_s, cls_ops_s) ->
 134     getTopBindsNames binds                      `thenRn` \ bind_names ->
 135     returnRn (unionManyBags constrs_s `unionBags`
 136               unionManyBags fields_s  `unionBags`
 137               unionManyBags cls_ops_s `unionBags` bind_names,
 138               listToBag tycon_s `unionBags` listToBag cls_s)
 139
 140 --------------
 141 getTyDeclNames :: RdrNameTyDecl
 142                -> RnM_Info s (RnName, Bag RnName, Bag RnName)   -- tycon, constrs and fields
 143
 144 getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc)
 145   = --getExtraRn                `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
 146     --pprTrace "getTyDeclNames:" (ppr PprDebug tycon) $
 147     --pprTrace "getTDN1:" (ppAboves [ ppCat [ppPStr m, ppPStr n] | ((OrigName m n), _) <- fmToList b_tc_names]) $
 148
 149     newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
 150     getConFieldNames (Just (nameExportFlag tycon_name)) emptyBag emptyBag emptyFM
 151                      condecls           `thenRn` \ (con_names, field_names) ->
 152     let
 153         rn_tycon   = RnData tycon_name con_names field_names
 154         rn_constrs = [ RnConstr name tycon_name | name <- con_names]
 155         rn_fields  = [ RnField name tycon_name | name <- field_names]
 156     in
 157     returnRn (rn_tycon, listToBag rn_constrs, listToBag rn_fields)
 158
 159 getTyDeclNames (TyNew _ tycon _ [NewConDecl con _ con_loc] _ _ src_loc)
 160   = newGlobalName src_loc Nothing False{-not val-} tycon        `thenRn` \ tycon_name ->
 161     newGlobalName con_loc (Just (nameExportFlag tycon_name)) True{-val-} con
 162                                         `thenRn` \ con_name ->
 163     returnRn (RnData tycon_name [con_name] [],
 164               unitBag (RnConstr con_name tycon_name),
 165               emptyBag)
 166
 167 getTyDeclNames (TySynonym tycon _ _ src_loc)
 168   = newGlobalName src_loc Nothing False{-not val-} tycon        `thenRn` \ tycon_name ->
 169     returnRn (RnSyn tycon_name, emptyBag, emptyBag)
 170
 171 ----------------
 172 getConFieldNames :: Maybe ExportFlag
 173                  -> Bag Name -> Bag Name
 174                  -> FiniteMap RdrName ()
 175                  -> [RdrNameConDecl]
 176                  -> RnM_Info s ([Name], [Name])
 177
 178 getConFieldNames exp constrs fields have []
 179   = returnRn (bagToList constrs, bagToList fields)
 180
 181 getConFieldNames exp constrs fields have (ConDecl con _ src_loc : rest)
 182   = newGlobalName src_loc exp True{-val-} con   `thenRn` \ con_name ->
 183     getConFieldNames exp (constrs `snocBag` con_name) fields have rest
 184
 185 getConFieldNames exp constrs fields have (ConOpDecl _ con _ src_loc : rest)
 186   = newGlobalName src_loc exp True{-val-} con   `thenRn` \ con_name ->
 187     getConFieldNames exp (constrs `snocBag` con_name) fields have rest
 188
 189 getConFieldNames exp constrs fields have (RecConDecl con fielddecls src_loc : rest)
 190   = mapRn (addErrRn . dupFieldErr con src_loc) dups     `thenRn_`
 191     newGlobalName src_loc exp True{-val-} con           `thenRn` \ con_name ->
 192     mapRn (newGlobalName src_loc exp True{-val-}) new_fields    `thenRn` \ field_names ->
 193     let
 194         all_constrs = constrs `snocBag` con_name
 195         all_fields  = fields  `unionBags` listToBag field_names
 196     in
 197     getConFieldNames exp all_constrs all_fields new_have rest
 198   where
 199     (uniq_fields, dups) = removeDups cmp (concat (map fst fielddecls))
 200     new_fields = filter (not . maybeToBool . lookupFM have) uniq_fields
 201     new_have   = addListToFM have (zip new_fields (repeat ()))
 202
 203 -------------
 204 getClassNames :: RdrNameClassDecl
 205               -> RnM_Info s (RnName, Bag RnName)        -- class and class ops
 206
 207 getClassNames (ClassDecl _ cname _ sigs _ _ src_loc)
 208   = newGlobalName src_loc Nothing False{-notval-} cname `thenRn` \ class_name ->
 209     getClassOpNames (Just (nameExportFlag class_name))
 210                                   sigs  `thenRn` \ op_names ->
 211     returnRn (RnClass class_name op_names,
 212               listToBag (map (\ n -> RnClassOp n class_name) op_names))
 213
 214 ---------------
 215 getClassOpNames :: Maybe ExportFlag
 216                 -> [RdrNameSig]
 217                 -> RnM_Info s [Name]
 218
 219 getClassOpNames exp [] = returnRn []
 220
 221 getClassOpNames exp (ClassOpSig op _ _ src_loc : sigs)
 222   = newGlobalName src_loc exp True{-val-} op `thenRn` \ op_name ->
 223     getClassOpNames exp sigs     `thenRn` \ op_names ->
 224     returnRn (op_name : op_names)
 225 getClassOpNames exp (_ : sigs)
 226   = getClassOpNames exp sigs
 227 \end{code}
 228
 229 *********************************************************
 230 *                                                       *
 231 \subsection{Bindings}
 232 *                                                       *
 233 *********************************************************
 234
 235 \begin{code}
 236 getTopBindsNames :: RdrNameHsBinds
 237                  -> RnM_Info s (Bag RnName)
 238
 239 getTopBindsNames binds = doBinds binds
 240
 241 doBinds EmptyBinds           = returnRn emptyBag
 242 doBinds (SingleBind bind)    = doBind bind
 243 doBinds (BindWith bind sigs) = doBind bind
 244 doBinds (ThenBinds binds1 binds2)
 245   = andRn unionBags (doBinds binds1) (doBinds binds2)
 246
 247 doBind EmptyBind          = returnRn emptyBag
 248 doBind (NonRecBind mbind) = doMBinds mbind
 249 doBind (RecBind mbind)    = doMBinds mbind
 250
 251 doMBinds EmptyMonoBinds                         = returnRn emptyBag
 252 doMBinds (PatMonoBind pat grhss_and_binds locn) = doPat locn pat
 253 doMBinds (FunMonoBind p_name _ _ locn)          = doName locn p_name
 254 doMBinds (AndMonoBinds mbinds1 mbinds2)
 255   = andRn unionBags (doMBinds mbinds1) (doMBinds mbinds2)
 256
 257 doPats locn pats
 258   = mapRn (doPat locn) pats     `thenRn` \ pats_s ->
 259     returnRn (unionManyBags pats_s)
 260
 261 doPat locn WildPatIn             = returnRn emptyBag
 262 doPat locn (LitPatIn _)          = returnRn emptyBag
 263 doPat locn (LazyPatIn pat)       = doPat locn pat
 264 doPat locn (VarPatIn var)        = doName locn var
 265 doPat locn (NegPatIn pat)        = doPat locn pat
 266 doPat locn (ParPatIn pat)        = doPat locn pat
 267 doPat locn (ListPatIn pats)      = doPats locn pats
 268 doPat locn (TuplePatIn pats)     = doPats locn pats
 269 doPat locn (ConPatIn name pats)  = doPats locn pats
 270 doPat locn (ConOpPatIn p1 op p2)
 271   = andRn unionBags (doPat locn p1) (doPat locn p2)
 272 doPat locn (AsPatIn as_name pat)
 273   = andRn unionBags (doName locn as_name) (doPat locn pat)
 274 doPat locn (RecPatIn name fields)
 275   = mapRn (doField locn) fields `thenRn` \ fields_s ->
 276     returnRn (unionManyBags fields_s)
 277
 278 doField locn (_, pat, _) = doPat locn pat
 279
 280 doName locn rdr
 281   = newGlobalName locn Nothing True{-val-} rdr `thenRn` \ name ->
 282     returnRn (unitBag (RnName name))
 283 \end{code}
 284
 285 *********************************************************
 286 *                                                       *
 287 \subsection{Creating a new global name}
 288 *                                                       *
 289 *********************************************************
 290
 291 \begin{code}
 292 newGlobalName :: SrcLoc
 293               -> Maybe ExportFlag
 294               -> Bool{-True<=>value name,False<=>tycon/class-}
 295               -> RdrName
 296               -> RnM_Info s Name
 297
 298 newGlobalName locn maybe_exp is_val_name (Unqual name)
 299   = getExtraRn          `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
 300     getModuleRn         `thenRn` \ mod ->
 301     rnGetUnique         `thenRn` \ u ->
 302     let
 303         orig = OrigName mod name
 304
 305         (uniq, is_toplev)
 306           = case (lookupFM b_keys orig) of
 307               Just (key,_) -> (key, True)
 308               Nothing      -> if not opt_CompilingGhcInternals then (u,True) else -- really here just to save gratuitous lookup
 309                               case (lookupFM (if is_val_name then b_val_names else b_tc_names) orig) of
 310                                 Nothing -> (u, True)
 311                                 Just xx -> (uniqueOf xx, False{-builtin!-})
 312
 313         exp = case maybe_exp of
 314                Just flag -> flag
 315                Nothing   -> rec_exp_fn n
 316
 317         n = if is_toplev
 318             then mkTopLevName  uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s
 319             else mkWiredInName uniq orig exp
 320     in
 321     returnRn n
 322
 323 newGlobalName locn maybe_exp is_val_name rdr@(Qual mod name)
 324   | opt_CompilingGhcInternals
 325   -- we are actually defining something that compiler knows about (e.g., Bool)
 326
 327   = getExtraRn          `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
 328     let
 329         orig = OrigName mod name
 330
 331         (uniq, is_toplev)
 332           = case (lookupFM b_keys orig) of
 333               Just (key,_) -> (key, True)
 334               Nothing      -> case (lookupFM (if is_val_name then b_val_names else b_tc_names) orig) of
 335                                 Nothing -> (pprPanic "newGlobalName:Qual:uniq:" (ppr PprDebug rdr), True)
 336                                 Just xx -> (uniqueOf xx, False{-builtin!-})
 337
 338         exp = case maybe_exp of
 339                Just flag -> flag
 340                Nothing   -> rec_exp_fn n
 341
 342         n = if is_toplev
 343             then mkTopLevName  uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s
 344             else mkWiredInName uniq orig exp
 345     in
 346     returnRn n
 347
 348   | otherwise
 349   = addErrRn (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
 350     returnRn (pprPanic "newGlobalName:Qual:" (ppr PprDebug rdr))
 351 \end{code}
 352
 353 *********************************************************
 354 *                                                       *
 355 \subsection{Imported names}
 356 *                                                       *
 357 *********************************************************
 358
 359 \begin{code}
 360 type ImportNameInfo
 361   = (GlobalNameInfo,
 362      FiniteMap OrigName RnName,         -- values imported so far
 363      FiniteMap OrigName RnName,         -- tycons/classes imported so far
 364      Name -> (ExportFlag, [SrcLoc]))    -- import flag and src locns;
 365                                         -- NB: this last field is in a knot
 366                                         -- and mustn't be tugged on!
 367
 368 type RnM_IInfo s r = RnMonad ImportNameInfo s r
 369
 370 ------------------------------------------------------------------
 371 doImportDecls ::
 372            IfaceCache
 373         -> GlobalNameInfo               -- builtin and knot name info
 374         -> UniqSupply
 375         -> [RdrNameImportDecl]          -- import declarations
 376         -> IO (Bag (RdrName,RnName),    -- imported values in scope
 377                Bag (RdrName,RnName),    -- imported tycons/classes in scope
 378                [Module],                -- directly imported modules
 379                Bag (Module,RnName),     -- unqualified import from module
 380                Bag RenamedFixityDecl,   -- fixity info for imported names
 381                Bag Error,
 382                Bag Warning)
 383
 384 doImportDecls iface_cache g_info us src_imps
 385   = fixIO ( \ ~(_, _, _, _, _, _, rec_imp_stuff) ->
 386         let
 387             rec_imp_fm = addListToUFM_C add_stuff emptyUFM (bagToList rec_imp_stuff)
 388             add_stuff (imp1,locns1) (imp2,locns2) = (lubExportFlag imp1 imp2, locns1 `unionBags` locns2)
 389
 390             rec_imp_fn :: Name -> (ExportFlag, [SrcLoc])
 391             rec_imp_fn n = case lookupUFM rec_imp_fm n of
 392                              Nothing            -> panic "RnNames:rec_imp_fn"
 393                              Just (flag, locns) -> (flag, bagToList locns)
 394
 395             i_info = (g_info, emptyFM, emptyFM, rec_imp_fn)
 396         in
 397         -- cache the imported modules
 398         -- this ensures that all directly imported modules
 399         -- will have their original name iface in scope
 400         -- pprTrace "doImportDecls:" (ppCat (map ppPStr imp_mods)) $
 401         accumulate (map (cachedIface iface_cache False SLIT("doImportDecls")) imp_mods) >>
 402
 403         -- process the imports
 404         doImports iface_cache i_info us all_imps
 405
 406     ) >>= \ (vals, tcs, unquals, fixes, errs, warns, _) ->
 407
 408     return (vals, tcs, imp_mods, unquals, fixes,
 409             imp_errs `unionBags` errs,
 410             imp_warns `unionBags` warns)
 411   where
 412     all_imps = implicit_prel  ++ src_imps
 413 --  all_imps = implicit_qprel ++ the_imps
 414
 415     explicit_prelude_imp
 416       = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps, mod == pRELUDE ])
 417
 418     implicit_prel | opt_NoImplicitPrelude = []
 419                   | explicit_prelude_imp  = [ImportDecl pRELUDE True  Nothing Nothing prel_loc]
 420                   | otherwise             = [ImportDecl pRELUDE False Nothing Nothing prel_loc]
 421
 422     prel_loc = mkBuiltinSrcLoc
 423
 424     (uniq_imps, imp_dups) = removeDups cmp_mod all_imps
 425     cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2
 426
 427     qprel_imps = [ imp | imp@(ImportDecl mod True Nothing _ _) <- src_imps,
 428                          mod == pRELUDE ]
 429
 430     qual_mods = [ (qual_name mod as_mod, imp) | imp@(ImportDecl mod True as_mod _ _) <- src_imps ]
 431     qual_name mod (Just as_mod) = as_mod
 432     qual_name mod Nothing       = mod
 433
 434     (_, qual_dups) = removeDups cmp_qual qual_mods
 435     bad_qual_dups = filter (not . all_same_mod) qual_dups
 436
 437     cmp_qual (q1,_) (q2,_) = cmpPString q1 q2
 438     all_same_mod ((q,ImportDecl mod _ _ _ _):rest)
 439       = all has_same_mod rest
 440       where
 441         has_same_mod (_,ImportDecl mod2 _ _ _ _) = mod == mod2
 442
 443     imp_mods  = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps ]
 444
 445     imp_warns = listToBag (map dupImportWarn imp_dups)
 446                 `unionBags`
 447                 listToBag (map qualPreludeImportWarn qprel_imps)
 448
 449     imp_errs  = listToBag (map dupQualImportErr bad_qual_dups)
 450
 451 -----------------------
 452 doImports :: IfaceCache
 453           -> ImportNameInfo
 454           -> UniqSupply
 455           -> [RdrNameImportDecl]        -- import declarations
 456           -> IO (Bag (RdrName,RnName),  -- imported values in scope
 457                  Bag (RdrName,RnName),  -- imported tycons/classes in scope
 458                  Bag (Module, RnName),  -- unqualified import from module
 459                  Bag RenamedFixityDecl, -- fixity info for imported names
 460                  Bag Error,
 461                  Bag Warning,
 462                 Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs
 463
 464 doImports iface_cache i_info us []
 465   = return (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag)
 466
 467 doImports iface_cache i_info@(g_info,done_vals,done_tcs,rec_imp_fn) us (imp:imps)
 468   = let
 469         (us1, us2) = splitUniqSupply us
 470     in
 471     doImport iface_cache i_info us1 imp
 472         >>= \ (vals1, tcs1, unquals1, fixes1, errs1, warns1, imps1) ->
 473     let
 474         ext_vals = foldl add_new_one done_vals (bagToList vals1)
 475         ext_tcs  = foldl add_new_one done_tcs  (bagToList tcs1)
 476     in
 477     doImports iface_cache (g_info,ext_vals,ext_tcs,rec_imp_fn) us2 imps
 478         >>= \ (vals2, tcs2, unquals2, fixes2, errs2, warns2, imps2) ->
 479     return (vals1    `unionBags` vals2,
 480             tcs1     `unionBags` tcs2,
 481             unquals1 `unionBags` unquals2,
 482             fixes1   `unionBags` fixes2,
 483             errs1    `unionBags` errs2,
 484             warns1   `unionBags` warns2,
 485             imps1    `unionBags` imps2)
 486   where
 487     add_new_one :: FiniteMap OrigName RnName -- ones done so far
 488                 -> (dont_care, RnName)
 489                 -> FiniteMap OrigName RnName -- extended
 490
 491     add_new_one fm (_, rn)
 492       = let
 493             orig = origName "add_new_one" rn
 494         in
 495         case (lookupFM fm orig) of
 496           Just  _ -> fm -- already there: no change
 497           Nothing -> addToFM fm orig rn
 498
 499 ----------------------
 500 doImport :: IfaceCache
 501          -> ImportNameInfo
 502          -> UniqSupply
 503          -> RdrNameImportDecl
 504          -> IO (Bag (RdrName,RnName),                   -- values
 505                 Bag (RdrName,RnName),                   -- tycons/classes
 506                 Bag (Module,RnName),                    -- unqual imports
 507                 Bag RenamedFixityDecl,
 508                 Bag Error,
 509                 Bag Warning,
 510                 Bag (RnName,(ExportFlag,Bag SrcLoc)))   -- import flags and src locs
 511
 512 doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
 513   = --let
 514     --  (b_vals, b_tcs, maybe_spec')
 515     --     = (emptyBag, emptyBag, maybe_spec)
 516     --in
 517     --pprTrace "doImport:" (ppPStr mod) $
 518     cachedIface iface_cache False SLIT("doImport") mod >>= \ maybe_iface ->
 519     return (maybe_iface, \ iface -> getOrigIEs iface maybe_spec)
 520             >>= \ (maybe_iface, do_ies) ->
 521
 522     case maybe_iface of
 523       Failed err ->
 524         return (emptyBag, emptyBag, emptyBag, emptyBag,
 525                 unitBag err, emptyBag, emptyBag)
 526       Succeeded iface ->
 527         let
 528             (ies, chk_ies, get_errs) = do_ies iface
 529         in
 530         doOrigIEs iface_cache info mod src_loc us ies
 531                 >>= \ (ie_vals, ie_tcs, imp_flags, errs, warns) ->
 532         accumulate (map (checkOrigIE iface_cache) chk_ies)
 533                 >>= \ chk_errs_warns ->
 534         let
 535             fold_ies   = foldBag unionBags pair_occ emptyBag
 536
 537             final_vals = {-OLD:mapBag fst_occ b_vals `unionBags`-} fold_ies ie_vals
 538             final_tcs  = {-OLD:mapBag fst_occ b_tcs  `unionBags`-} fold_ies ie_tcs
 539             final_vals_list = bagToList final_vals
 540         in
 541         accumulate (map (getFixityDecl iface_cache . snd) final_vals_list)
 542                         >>= \ fix_maybes_errs ->
 543         let
 544             (chk_errs, chk_warns)  = unzip chk_errs_warns
 545             (fix_maybes, fix_errs) = unzip fix_maybes_errs
 546
 547             unquals    = if qual{-ified import-}
 548                          then emptyBag
 549                          else mapBag pair_as (ie_vals `unionBags` ie_tcs)
 550
 551             final_fixes = listToBag (catMaybes fix_maybes)
 552
 553             final_errs  = mapBag (\ err -> err mod src_loc) (unionManyBags (get_errs:chk_errs))
 554                           `unionBags` errs `unionBags` unionManyBags fix_errs
 555             final_warns = mapBag (\ warn -> warn mod src_loc) (unionManyBags chk_warns)
 556                           `unionBags` warns
 557             imp_stuff   = mapBag (\ (n,imp) -> (n,(imp,unitBag src_loc))) imp_flags
 558         in
 559         return (final_vals, final_tcs, unquals, final_fixes,
 560                 final_errs, final_warns, imp_stuff)
 561   where
 562     as_mod :: Module
 563     as_mod = case maybe_as of {Nothing -> mod; Just as_this -> as_this}
 564
 565     mk_occ :: FAST_STRING -> RdrName
 566     mk_occ str = if qual then Qual as_mod str else Unqual str
 567
 568     fst_occ :: (FAST_STRING, RnName) -> (RdrName, RnName)
 569     fst_occ (str, rn) = (mk_occ str, rn)
 570
 571     pair_occ :: RnName -> Bag (RdrName, RnName)
 572     pair_occ rn
 573       = let
 574             str      = getLocalName rn
 575             qual_bag = unitBag (Qual as_mod str, rn)
 576         in
 577         if qual
 578         then qual_bag
 579         else qual_bag -- the qualified name is *also* visible
 580             `snocBag` (Unqual str, rn)
 581
 582
 583     pair_as :: RnName -> (Module, RnName)
 584     pair_as  rn = (as_mod, rn)
 585
 586 -----------------------------
 587 {-
 588 getBuiltins :: ImportNameInfo
 589             -> Module
 590             -> Maybe (Bool, [RdrNameIE])
 591             -> (Bag (FAST_STRING, RnName),
 592                 Bag (FAST_STRING, RnName),
 593                 Maybe (Bool, [RdrNameIE])  -- return IEs that had no effect
 594                )
 595
 596 getBuiltins _ modname maybe_spec
 597 -- | modname `notElem` modulesWithBuiltins
 598   = (emptyBag, emptyBag, maybe_spec)
 599
 600 getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) modname maybe_spec
 601   = case maybe_spec of
 602       Nothing           -> (all_vals, all_tcs, Nothing)
 603
 604       Just (True, ies)  -> -- hiding does not work for builtin names
 605                            trace "NOTE: `import Prelude hiding ...' does not hide built-in names" $
 606                            (all_vals, all_tcs, maybe_spec)
 607
 608       Just (False, ies) -> let
 609                               (vals,tcs,ies_left) = do_builtin ies
 610                            in
 611                            (vals, tcs, Just (False, ies_left))
 612   where
 613     all_vals = do_all_builtin (fmToList b_val_names)
 614     all_tcs  = do_all_builtin (fmToList b_tc_names)
 615
 616     do_all_builtin [] = emptyBag
 617     do_all_builtin (((OrigName mod str),rn):rest)
 618       = --pprTrace "do_all_builtin:" (ppCat [ppPStr modname, ppPStr mod, ppPStr str]) $
 619         (if mod == modname then consBag (str, rn) else id) (do_all_builtin rest)
 620
 621     do_builtin [] = (emptyBag,emptyBag,[])
 622     do_builtin (ie:ies)
 623       = let
 624             (str, orig)
 625               = case (ie_name ie) of
 626                   Unqual s -> (s, OrigName modname s)
 627                   Qual m s -> pprTrace "do_builtin:surprising qual!" (ppCat [ppPStr m, ppPStr s]) $
 628                               (s, OrigName modname s)
 629         in
 630         case (lookupFM b_tc_names orig) of      -- NB: we favour the tycon/class FM...
 631           Just rn -> case (ie,rn) of
 632              (IEThingAbs _, WiredInTyCon tc)
 633                 -> (vals, (str, rn) `consBag` tcs, ies_left)
 634              (IEThingAll _, WiredInTyCon tc)
 635                 -> (listToBag (map (\ id -> (getLocalName id, WiredInId id))
 636                                    (tyConDataCons tc))
 637                     `unionBags` vals,
 638                     (str,rn) `consBag` tcs, ies_left)
 639              (IEThingWith _ _, WiredInTyCon tc) -- No checking of With...
 640                 -> (listToBag (map (\ id -> (nameOf (origName "IEThingWith" id), WiredInId id))
 641                                    (tyConDataCons tc))
 642                     `unionBags` vals,
 643                     (str,rn) `consBag` tcs, ies_left)
 644              _ -> panic "importing builtin names (1)"
 645
 646           Nothing ->
 647             case (lookupFM b_val_names orig) of
 648               Nothing -> (vals, tcs, ie:ies_left)
 649               Just rn -> case (ie,rn) of
 650                  (IEVar _, WiredInId _)
 651                     -> ((str, rn) `consBag` vals, tcs, ies_left)
 652                  _ -> panic "importing builtin names (2)"
 653       where
 654         (vals, tcs, ies_left) = do_builtin ies
 655 -}
 656
 657 -------------------------
 658 getOrigIEs :: ParsedIface
 659            -> Maybe (Bool, [RdrNameIE]) -- "hiding" or not, blah, blah, blah
 660            -> ([IE OrigName],
 661                [(IE OrigName, ExportFlag)],
 662                Bag (Module -> SrcLoc -> Error))
 663
 664 getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) Nothing                   -- import all
 665   = (map mkAllIE (eltsFM exps), [], emptyBag)
 666
 667 getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies))        -- import hiding
 668   = (map mkAllIE (eltsFM exps_left), found_ies, errs)
 669   where
 670     (found_ies, errs) = lookupIEs exps ies
 671     exps_left = delListFromFM exps (map (getLocalName.ie_name.fst) found_ies)
 672
 673 getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies))       -- import these
 674   = (map fst found_ies, found_ies, errs)
 675   where
 676     (found_ies, errs) = lookupIEs exps ies
 677
 678 ------------------------------------------------
 679 mkAllIE :: (OrigName, ExportFlag) -> IE OrigName
 680
 681 mkAllIE (orig,ExportAbs)
 682   = --ASSERT(isLexCon (nameOf orig))
 683     -- the ASSERT is correct, but it is too easy to
 684     -- trigger when writing .hi files by hand (e.g.
 685     -- when hackily breaking a module loop)
 686     IEThingAbs orig
 687 mkAllIE (orig, ExportAll)
 688   | isLexCon name_orig || isLexSpecialSym name_orig
 689   = IEThingAll orig
 690   | otherwise
 691   = IEVar orig
 692   where
 693     name_orig = nameOf orig
 694
 695 ------------
 696 lookupIEs :: ExportsMap
 697           -> [RdrNameIE]
 698           -> ([(IE OrigName, ExportFlag)], -- IEs we found, orig-ified
 699               Bag (Module -> SrcLoc -> Error))
 700
 701 lookupIEs exps ies
 702   = foldr go ([], emptyBag) ies
 703   where
 704     go ie (already, errs)
 705       = let
 706             str = case (ie_name ie) of
 707                     Unqual s -> s
 708                     Qual m s -> s
 709         in
 710         case (lookupFM exps str) of
 711           Nothing ->
 712             (already, unknownImpSpecErr ie `consBag` errs)
 713           Just (orig, flag) ->
 714             ((orig_ie orig ie, flag) : already,
 715              adderr_if (seen_ie orig already) (duplicateImpSpecErr ie) errs)
 716
 717     orig_ie orig (IEVar n)          = IEVar       orig
 718     orig_ie orig (IEThingAbs n)     = IEThingAbs  orig
 719     orig_ie orig (IEThingAll n)     = IEThingAll  orig
 720     orig_ie orig (IEThingWith n ns) = IEThingWith orig (map re_orig ns)
 721       where
 722         (OrigName mod _) = orig
 723         re_orig (Unqual s) = OrigName mod s
 724
 725     seen_ie orig seen_ies = any (\ (ie,_) -> orig == ie_name ie) seen_ies
 726
 727 --------------------------------------------
 728 doOrigIEs iface_cache info mod src_loc us []
 729   = return (emptyBag,emptyBag,emptyBag,emptyBag,emptyBag)
 730
 731 doOrigIEs iface_cache info mod src_loc us (ie:ies)
 732   = let
 733         (us1, us2) = splitUniqSupply us
 734     in
 735     doOrigIE iface_cache info mod src_loc us1 ie
 736         >>= \ (vals1, tcs1, imps1, errs1, warns1) ->
 737     doOrigIEs iface_cache info mod src_loc us2 ies
 738         >>= \ (vals2, tcs2, imps2, errs2, warns2) ->
 739     return (vals1    `unionBags` vals2,
 740             tcs1     `unionBags` tcs2,
 741             imps1    `unionBags` imps2,
 742             errs1    `unionBags` errs2,
 743             warns1   `unionBags` warns2)
 744
 745 ----------------------
 746 doOrigIE :: IfaceCache
 747          -> ImportNameInfo
 748          -> Module
 749          -> SrcLoc
 750          -> UniqSupply
 751          -> IE OrigName
 752          -> IO (Bag RnName,                     -- values
 753                 Bag RnName,                     -- tycons/classes
 754                 Bag (RnName,ExportFlag),        -- import flags
 755                 Bag Error,
 756                 Bag Warning)
 757
 758 doOrigIE iface_cache info mod src_loc us ie
 759   = with_decl iface_cache (ie_name ie)
 760         avoided_fn
 761         (\ err  -> (emptyBag, emptyBag, emptyBag, unitBag err, emptyBag))
 762         (\ decl -> case initRn True mod emptyRnEnv us
 763                                (setExtraRn info $
 764                                 pushSrcLocRn src_loc $
 765                                 getIfaceDeclNames ie decl)
 766                    of
 767                    ((vals, tcs, imps), errs, warns) -> (vals, tcs, imps, errs, warns))
 768   where
 769     avoided_fn Nothing -- the thing should be in the source
 770       = (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag)
 771     avoided_fn (Just (Left  rn@(WiredInId _))) -- a builtin value brought into scope
 772       = (unitBag rn, emptyBag, emptyBag, emptyBag, emptyBag)
 773     avoided_fn (Just (Right rn@(WiredInTyCon tc)))
 774         -- a builtin tc brought into scope; we also must bring its
 775         -- data constructors into scope
 776       = --pprTrace "avoided:Right:" (ppr PprDebug rn) $
 777         (listToBag [WiredInId dc | dc <- tyConDataCons tc], unitBag rn, emptyBag, emptyBag, emptyBag)
 778
 779 -------------------------
 780 checkOrigIE :: IfaceCache
 781             -> (IE OrigName, ExportFlag)
 782             -> IO (Bag (Module -> SrcLoc -> Error), Bag (Module -> SrcLoc -> Warning))
 783
 784 checkOrigIE iface_cache (IEThingAll n, ExportAbs)
 785   = with_decl iface_cache n
 786         (\ _    -> (emptyBag, emptyBag))
 787         (\ err  -> (unitBag (\ mod locn -> err), emptyBag))
 788         (\ decl -> case decl of
 789                 TypeSig _ _ _ -> (emptyBag, unitBag (allWhenSynImpSpecWarn n))
 790                 other         -> (unitBag (allWhenAbsImpSpecErr n), emptyBag))
 791
 792 checkOrigIE iface_cache (IEThingWith n ns, ExportAbs)
 793   = return (unitBag (withWhenAbsImpSpecErr n), emptyBag)
 794
 795 checkOrigIE iface_cache (IEThingWith n ns, ExportAll)
 796   = with_decl iface_cache n
 797         (\ _    -> (emptyBag, emptyBag))
 798         (\ err  -> (unitBag (\ mod locn -> err), emptyBag))
 799         (\ decl -> case decl of
 800                 NewTypeSig _ con _ _         -> (check_with "constructors" [con] ns, emptyBag)
 801                 DataSig    _ cons fields _ _ -> (check_with "constructors (and fields)" (cons++fields) ns, emptyBag)
 802                 ClassSig   _ ops _ _         -> (check_with "class ops"   ops   ns, emptyBag))
 803   where
 804     check_with str has origs
 805       | sortLt (<) (map getLocalName has) == sortLt (<) (map nameOf origs)
 806       = emptyBag
 807       | otherwise
 808       = unitBag (withImpSpecErr str n has origs)
 809
 810 checkOrigIE iface_cache other
 811   = return (emptyBag, emptyBag)
 812
 813 -----------------------
 814 with_decl :: IfaceCache
 815           -> OrigName
 816           -> (Maybe (Either RnName RnName) -> something) -- if avoided..
 817           -> (Error        -> something)                 -- if an error...
 818           -> (RdrIfaceDecl -> something)                 -- if OK...
 819           -> IO something
 820
 821 with_decl iface_cache n do_avoid do_err do_decl
 822   = cachedDecl iface_cache (isLexCon n_name || isLexSpecialSym n_name) n   >>= \ maybe_decl ->
 823     case maybe_decl of
 824       CachingAvoided info -> return (do_avoid info)
 825       CachingFail    err  -> return (do_err   err)
 826       CachingHit     decl -> return (do_decl  decl)
 827   where
 828     n_name = nameOf n
 829
 830 -------------
 831 getFixityDecl :: IfaceCache
 832               -> RnName
 833               -> IO (Maybe RenamedFixityDecl, Bag Error)
 834
 835 getFixityDecl iface_cache rn
 836   = let
 837         (OrigName mod str) = origName "getFixityDecl" rn
 838
 839         succeeded infx i = return (Just (infx rn i), emptyBag)
 840     in
 841     cachedIface iface_cache True str mod >>= \ maybe_iface ->
 842     case maybe_iface of
 843       Failed err ->
 844         return (Nothing, unitBag err)
 845       Succeeded (ParsedIface _ _ _ _ _ _ _ _ fixes _ _ _ _) ->
 846         case lookupFM fixes str of
 847           Nothing           -> return (Nothing, emptyBag)
 848           Just (InfixL _ i) -> succeeded InfixL i
 849           Just (InfixR _ i) -> succeeded InfixR i
 850           Just (InfixN _ i) -> succeeded InfixN i
 851
 852 ie_name (IEVar n)         = n
 853 ie_name (IEThingAbs n)    = n
 854 ie_name (IEThingAll n)    = n
 855 ie_name (IEThingWith n _) = n
 856
 857 adderr_if True  err errs = err `consBag` errs
 858 adderr_if False err errs = errs
 859 \end{code}
 860
 861 *********************************************************
 862 *                                                       *
 863 \subsection{Actually creating the imported names}
 864 *                                                       *
 865 *********************************************************
 866
 867 \begin{code}
 868 getIfaceDeclNames :: IE OrigName -> RdrIfaceDecl
 869                   -> RnM_IInfo s (Bag RnName,                   -- values
 870                                   Bag RnName,                   -- tycons/classes
 871                                   Bag (RnName,ExportFlag))      -- import flags
 872
 873 getIfaceDeclNames ie (ValSig val src_loc _)
 874   = newImportedName False src_loc Nothing Nothing val   `thenRn` \ val_name ->
 875     returnRn (unitBag (RnName val_name),
 876               emptyBag,
 877               unitBag (RnName val_name, ExportAll))
 878
 879 getIfaceDeclNames ie (TypeSig tycon src_loc _)
 880   = newImportedName True src_loc Nothing Nothing tycon  `thenRn` \ tycon_name ->
 881     returnRn (emptyBag,
 882               unitBag (RnSyn tycon_name),
 883               unitBag (RnSyn tycon_name, ExportAll))
 884
 885 getIfaceDeclNames ie (NewTypeSig tycon con src_loc _)
 886   = newImportedName True src_loc Nothing Nothing tycon  `thenRn` \ tycon_name ->
 887     newImportedName False src_loc (Just (nameExportFlag tycon_name))
 888                                   (Just (nameImportFlag tycon_name))
 889                                   con                   `thenRn` \ con_name ->
 890     returnRn (if imp_all (imp_flag ie) then
 891                   unitBag (RnConstr con_name tycon_name)
 892               else
 893                   emptyBag,
 894               unitBag (RnData tycon_name [con_name] []),
 895               unitBag (RnData tycon_name [con_name] [], imp_flag ie))
 896
 897 getIfaceDeclNames ie (DataSig tycon cons fields src_loc _)
 898   = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
 899     let
 900         map_me = mapRn (newImportedName False src_loc
 901                                 (Just (nameExportFlag tycon_name))
 902                                 (Just (nameImportFlag tycon_name)))
 903     in
 904     map_me cons     `thenRn` \ con_names ->
 905     map_me fields   `thenRn` \ field_names ->
 906     let
 907         rn_tycon   = RnData tycon_name con_names field_names
 908         rn_constrs = [ RnConstr name tycon_name | name <- con_names ]
 909         rn_fields  = [ RnField name tycon_name | name <- field_names ]
 910     in
 911     returnRn (if imp_all (imp_flag ie) then
 912                   listToBag rn_constrs `unionBags` listToBag rn_fields
 913               else
 914                   emptyBag,
 915               unitBag rn_tycon,
 916               unitBag (rn_tycon, imp_flag ie))
 917
 918 getIfaceDeclNames ie (ClassSig cls ops src_loc _)
 919   = newImportedName True src_loc Nothing Nothing cls `thenRn` \ cls_name ->
 920     mapRn (newImportedName False src_loc (Just (nameExportFlag cls_name))
 921                                          (Just (nameImportFlag cls_name)))
 922                                             ops `thenRn` \ op_names ->
 923     returnRn (if imp_all (imp_flag ie) then
 924                   listToBag (map (\ n -> RnClassOp n cls_name) op_names)
 925               else
 926                   emptyBag,
 927               unitBag (RnClass cls_name op_names),
 928               unitBag (RnClass cls_name op_names, imp_flag ie))
 929
 930
 931 imp_all ExportAll = True
 932 imp_all _         = False
 933
 934 imp_flag (IEThingAbs _)    = ExportAbs
 935 imp_flag (IEThingAll _)    = ExportAll
 936 imp_flag (IEThingWith _ _) = ExportAll
 937 \end{code}
 938
 939 *********************************************************
 940 *                                                       *
 941 \subsection{Creating a new imported name}
 942 *                                                       *
 943 *********************************************************
 944
 945 \begin{code}
 946 newImportedName :: Bool                 -- True => tycon or class
 947                 -> SrcLoc
 948                 -> Maybe ExportFlag     -- maybe export flag
 949                 -> Maybe ExportFlag     -- maybe import flag
 950                 -> RdrName              -- orig name
 951                 -> RnM_IInfo s Name
 952
 953 newImportedName tycon_or_class locn maybe_exp maybe_imp rdr
 954   = let
 955         orig = qualToOrigName rdr
 956     in
 957     getExtraRn `thenRn` \ ((_,b_keys,rec_exp_fn,rec_occ_fn),done_vals,done_tcs,rec_imp_fn) ->
 958     case ((if tycon_or_class
 959            then lookupFM done_tcs
 960            else lookupFM done_vals) orig) of
 961
 962       Just rn -> returnRn (getName rn)
 963       Nothing ->
 964         rnGetUnique     `thenRn` \ u ->
 965         let
 966             uniq = case lookupFM b_keys orig of
 967                      Nothing      -> u
 968                      Just (key,_) -> key
 969
 970             exp  = case maybe_exp of
 971                      Just xx -> xx
 972                      Nothing -> rec_exp_fn n
 973
 974             imp  = case maybe_imp of
 975                      Just xx -> xx
 976                      Nothing -> imp_flag
 977
 978             (imp_flag, imp_locs) = rec_imp_fn n
 979
 980             n = mkImportedName uniq orig imp locn imp_locs exp (rec_occ_fn n) -- NB: two "n"s
 981         in
 982         returnRn n
 983 \end{code}
 984
 985 \begin{code}
 986 globalDupNamesErr rdr rns sty
 987   = ppAboves (message : map pp_dup rns)
 988   where
 989     message   = ppBesides [ppStr "multiple declarations of `", pprNonSym sty rdr, ppStr "'"]
 990
 991     pp_dup rn = addShortErrLocLine (get_loc rn) (\ sty ->
 992                 ppCat [pp_descrip rn, pprNonSym sty rn]) sty
 993
 994     get_loc rn = case getImpLocs rn of
 995                      []   -> getSrcLoc rn
 996                      locs -> head locs
 997
 998     pp_descrip (RnName _)      = ppStr "as a value:"
 999     pp_descrip (RnSyn  _)      = ppStr "as a type synonym:"
1000     pp_descrip (RnData _ _ _)  = ppStr "as a data type:"
1001     pp_descrip (RnConstr _ _)  = ppStr "as a data constructor:"
1002     pp_descrip (RnField _ _)   = ppStr "as a record field:"
1003     pp_descrip (RnClass _ _)   = ppStr "as a class:"
1004     pp_descrip (RnClassOp _ _) = ppStr "as a class method:"
1005     pp_descrip _               = ppNil
1006
1007 dupImportWarn (ImportDecl m1 _ _ _ locn1 : dup_imps) sty
1008   = ppAboves (item1 : map dup_item dup_imps)
1009   where
1010     item1 = addShortWarnLocLine locn1 (\ sty ->
1011             ppCat [ppStr "multiple imports from module", ppPStr m1]) sty
1012
1013     dup_item (ImportDecl m _ _ _ locn)
1014           = addShortWarnLocLine locn (\ sty ->
1015             ppCat [ppStr "here was another import from module", ppPStr m]) sty
1016
1017 qualPreludeImportWarn (ImportDecl m _ _ _ locn)
1018   = addShortWarnLocLine locn (\ sty ->
1019     ppCat [ppStr "qualified import of prelude module", ppPStr m])
1020
1021 dupQualImportErr ((q1,ImportDecl _ _ _ _ locn1):dup_quals) sty
1022   = ppAboves (item1 : map dup_item dup_quals)
1023   where
1024     item1 = addShortErrLocLine locn1 (\ sty ->
1025             ppCat [ppStr "multiple imports (from different modules) with same qualified name", ppPStr q1]) sty
1026
1027     dup_item (q,ImportDecl _ _ _ _ locn)
1028           = addShortErrLocLine locn (\ sty ->
1029             ppCat [ppStr "here was another import with qualified name", ppPStr q]) sty
1030
1031 unknownImpSpecErr ie imp_mod locn
1032   = addShortErrLocLine locn (\ sty ->
1033     ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " does not export `", ppr sty (ie_name ie), ppStr "'"])
1034
1035 duplicateImpSpecErr ie imp_mod locn
1036   = addShortErrLocLine locn (\ sty ->
1037     ppBesides [ppStr "`", ppr sty (ie_name ie), ppStr "' already seen in import list"])
1038
1039 allWhenSynImpSpecWarn n imp_mod locn
1040   = addShortWarnLocLine locn (\ sty ->
1041     ppBesides [ppStr "type synonym `", ppr sty n, ppStr "' should not be imported with (..)"])
1042
1043 allWhenAbsImpSpecErr n imp_mod locn
1044   = addShortErrLocLine locn (\ sty ->
1045     ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " only exports `", ppr sty n, ppStr "' abstractly"])
1046
1047 withWhenAbsImpSpecErr n imp_mod locn
1048   = addShortErrLocLine locn (\ sty ->
1049     ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " only exports `", ppr sty n, ppStr "' abstractly"])
1050
1051 withImpSpecErr str n has ns imp_mod locn
1052   = addErrLoc locn "" (\ sty ->
1053     ppAboves [ ppBesides [ppStr "inconsistent list of", ppStr str, ppStr "in import list for `", ppr sty n, ppStr "'"],
1054                ppCat [ppStr "    expected:", ppInterleave ppComma (map (ppr sty) has)],
1055                ppCat [ppStr "    found:   ", ppInterleave ppComma (map (ppr sty) ns)] ])
1056
1057 dupFieldErr con locn (dup:rest)
1058   = addShortErrLocLine locn (\ sty ->
1059     ppBesides [ppStr "record field `", ppr sty dup, ppStr "declared multiple times in `", ppr sty con, ppStr "'"])
1060 \end{code}