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         GlobalNameInfo(..)
  12     ) where
  13
  14 import PreludeGlaST     ( MutableVar(..) )
  15
  16 import Ubiq
  17
  18 import HsSyn
  19 import RdrHsSyn
  20 import RnHsSyn
  21
  22 import RnMonad
  23 import RnIfaces         ( IfaceCache(..), cachedIface, cachedDecl )
  24 import RnUtils          ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv,
  25                           lubExportFlag, qualNameErr, dupNamesErr )
  26 import ParseUtils       ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst )
  27
  28
  29 import Bag              ( emptyBag, unitBag, consBag, unionBags, unionManyBags,
  30                           mapBag, listToBag, bagToList )
  31 import CmdLineOpts      ( opt_NoImplicitPrelude )
  32 import ErrUtils         ( Error(..), Warning(..), addShortErrLocLine )
  33 import FiniteMap        ( emptyFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM )
  34 import Id               ( GenId )
  35 import Maybes           ( maybeToBool, catMaybes, MaybeErr(..) )
  36 import Name             ( RdrName(..), Name, isQual, mkTopLevName,
  37                           mkImportedName, nameExportFlag, nameImportFlag,
  38                           getLocalName, getSrcLoc, pprNonSym, moduleNamePair,
  39                           isLexCon, isRdrLexCon, ExportFlag(..)
  40                         )
  41 import PrelInfo         ( BuiltinNames(..), BuiltinKeys(..) )
  42 import PrelMods         ( fromPrelude, pRELUDE )
  43 import Pretty
  44 import SrcLoc           ( SrcLoc, mkIfaceSrcLoc )
  45 import TyCon            ( tyConDataCons )
  46 import UniqFM           ( emptyUFM, addListToUFM_C, lookupUFM )
  47 import UniqSupply       ( splitUniqSupply )
  48 import Util             ( isIn, cmpPString, sortLt, removeDups, equivClasses, panic, assertPanic )
  49 \end{code}
  50
  51
  52 \begin{code}
  53 type GlobalNameInfo = (BuiltinNames,
  54                        BuiltinKeys,
  55                        Name -> ExportFlag,      -- export flag
  56                        Name -> [RdrName])       -- occurence names
  57
  58 type RnM_Info s r = RnMonad GlobalNameInfo s r
  59
  60 getGlobalNames ::
  61            IfaceCache
  62         -> GlobalNameInfo
  63         -> UniqSupply
  64         -> RdrNameHsModule
  65         -> IO (RnEnv,
  66                [Module],                -- directly imported modules
  67                Bag (Module,RnName),     -- unqualified imports from module
  68                Bag RenamedFixityDecl,   -- imported fixity decls
  69                Bag Error,
  70                Bag Warning)
  71
  72 getGlobalNames iface_cache info us
  73                (HsModule mod _ _ imports _ ty_decls _ cls_decls _ _ _ binds _ _)
  74   = case initRn True mod emptyRnEnv us1
  75                 (setExtraRn info $
  76                  getSourceNames ty_decls cls_decls binds)
  77     of { ((src_vals, src_tcs), src_errs, src_warns) ->
  78
  79     doImportDecls iface_cache info us2 imports  >>=
  80         \ (imp_vals, imp_tcs, imp_mods, unqual_imps, imp_fixes, imp_errs, imp_warns) ->
  81
  82     let
  83         unqual_vals = mapBag (\rn -> (Unqual (getLocalName rn), rn)) src_vals
  84         unqual_tcs  = mapBag (\rn -> (Unqual (getLocalName rn), rn)) src_tcs
  85
  86         all_vals = bagToList (unqual_vals `unionBags` imp_vals)
  87         all_tcs  = bagToList (unqual_tcs  `unionBags` imp_tcs)
  88
  89         (all_env, dups) = extendGlobalRnEnv emptyRnEnv all_vals all_tcs
  90
  91         dup_errs = map dup_err (equivClasses cmp_rdr (bagToList dups))
  92         cmp_rdr (rdr1,_,_) (rdr2,_,_) = cmp rdr1 rdr2
  93         dup_err ((rdr,rn,rn'):rest) = globalDupNamesErr rdr (rn:rn': [rn|(_,_,rn)<-rest])
  94
  95         all_errs  = src_errs  `unionBags` imp_errs `unionBags` listToBag dup_errs
  96         all_warns = src_warns `unionBags` imp_warns
  97     in
  98     return (all_env, imp_mods, unqual_imps, imp_fixes, all_errs, all_warns)
  99     }
 100   where
 101     (us1, us2) = splitUniqSupply us
 102 \end{code}
 103
 104 *********************************************************
 105 *                                                       *
 106 \subsection{Top-level source names}
 107 *                                                       *
 108 *********************************************************
 109
 110 \begin{code}
 111 getSourceNames ::
 112            [RdrNameTyDecl]
 113         -> [RdrNameClassDecl]
 114         -> RdrNameHsBinds
 115         -> RnM_Info s (Bag RnName,      -- values
 116                        Bag RnName)      -- tycons/classes
 117
 118 getSourceNames ty_decls cls_decls binds
 119   = mapAndUnzipRn getTyDeclNames ty_decls   `thenRn` \ (tycon_s, constrs_s) ->
 120     mapAndUnzipRn getClassNames cls_decls  `thenRn` \ (cls_s, cls_ops_s) ->
 121     getTopBindsNames binds                         `thenRn` \ bind_names ->
 122     returnRn (unionManyBags constrs_s `unionBags`
 123               unionManyBags cls_ops_s `unionBags` bind_names,
 124               listToBag tycon_s `unionBags` listToBag cls_s)
 125
 126
 127 getTyDeclNames :: RdrNameTyDecl
 128                -> RnM_Info s (RnName, Bag RnName)       -- tycon and constrs
 129
 130 getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc)
 131   = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
 132     mapRn (getConDeclName (Just (nameExportFlag tycon_name)))
 133                                condecls `thenRn` \ con_names ->
 134     returnRn (RnData tycon_name con_names,
 135               listToBag (map (\ n -> RnConstr n tycon_name) con_names))
 136
 137 getTyDeclNames (TyNew _ tycon _ condecls _ _ src_loc)
 138   = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
 139     mapRn (getConDeclName (Just (nameExportFlag tycon_name)))
 140                                condecls `thenRn` \ con_names ->
 141     returnRn (RnData tycon_name con_names,
 142               listToBag (map (\ n -> RnConstr n tycon_name) con_names))
 143
 144 getTyDeclNames (TySynonym tycon _ _ src_loc)
 145   = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
 146     returnRn (RnSyn tycon_name, emptyBag)
 147
 148 getConDeclName exp (ConDecl con _ src_loc)
 149   = newGlobalName src_loc exp con
 150 getConDeclName exp (ConOpDecl _ op _ src_loc)
 151   = newGlobalName src_loc exp op
 152 getConDeclName exp (NewConDecl con _ src_loc)
 153   = newGlobalName src_loc exp con
 154 getConDeclName exp (RecConDecl con fields src_loc)
 155   = panic "getConDeclName:RecConDecl"
 156     newGlobalName src_loc exp con
 157
 158
 159 getClassNames :: RdrNameClassDecl
 160               -> RnM_Info s (RnName, Bag RnName)        -- class and class ops
 161
 162 getClassNames (ClassDecl _ cname _ sigs _ _ src_loc)
 163   = newGlobalName src_loc Nothing cname `thenRn` \ class_name ->
 164     getClassOpNames (Just (nameExportFlag class_name))
 165                                   sigs  `thenRn` \ op_names ->
 166     returnRn (RnClass class_name op_names,
 167               listToBag (map (\ n -> RnClassOp n class_name) op_names))
 168
 169 getClassOpNames exp []
 170   = returnRn []
 171 getClassOpNames exp (ClassOpSig op _ _ src_loc : sigs)
 172   = newGlobalName src_loc exp op `thenRn` \ op_name ->
 173     getClassOpNames exp sigs     `thenRn` \ op_names ->
 174     returnRn (op_name : op_names)
 175 getClassOpNames exp (_ : sigs)
 176   = getClassOpNames exp sigs
 177 \end{code}
 178
 179 *********************************************************
 180 *                                                       *
 181 \subsection{Bindings}
 182 *                                                       *
 183 *********************************************************
 184
 185 \begin{code}
 186 getTopBindsNames :: RdrNameHsBinds
 187                  -> RnM_Info s (Bag RnName)
 188
 189 getTopBindsNames binds = doBinds binds
 190
 191 doBinds EmptyBinds           = returnRn emptyBag
 192 doBinds (SingleBind bind)    = doBind bind
 193 doBinds (BindWith bind sigs) = doBind bind
 194 doBinds (ThenBinds binds1 binds2)
 195   = andRn unionBags (doBinds binds1) (doBinds binds2)
 196
 197 doBind EmptyBind          = returnRn emptyBag
 198 doBind (NonRecBind mbind) = doMBinds mbind
 199 doBind (RecBind mbind)    = doMBinds mbind
 200
 201 doMBinds EmptyMonoBinds                         = returnRn emptyBag
 202 doMBinds (PatMonoBind pat grhss_and_binds locn) = doPat locn pat
 203 doMBinds (FunMonoBind p_name _ _ locn)          = doName locn p_name
 204 doMBinds (AndMonoBinds mbinds1 mbinds2)
 205   = andRn unionBags (doMBinds mbinds1) (doMBinds mbinds2)
 206
 207 doPats locn pats
 208   = mapRn (doPat locn) pats     `thenRn` \ pats_s ->
 209     returnRn (unionManyBags pats_s)
 210
 211 doPat locn WildPatIn             = returnRn emptyBag
 212 doPat locn (LitPatIn _)          = returnRn emptyBag
 213 doPat locn (LazyPatIn pat)       = doPat locn pat
 214 doPat locn (VarPatIn var)        = doName locn var
 215 doPat locn (NegPatIn pat)        = doPat locn pat
 216 doPat locn (ParPatIn pat)        = doPat locn pat
 217 doPat locn (ListPatIn pats)      = doPats locn pats
 218 doPat locn (TuplePatIn pats)     = doPats locn pats
 219 doPat locn (ConPatIn name pats)  = doPats locn pats
 220 doPat locn (ConOpPatIn p1 op p2)
 221   = andRn unionBags (doPat locn p1) (doPat locn p2)
 222 doPat locn (AsPatIn as_name pat)
 223   = andRn unionBags (doName locn as_name) (doPat locn pat)
 224 doPat locn (RecPatIn name fields)
 225   = mapRn (doField locn) fields `thenRn` \ fields_s ->
 226     returnRn (unionManyBags fields_s)
 227
 228 doField locn (_, pat, _) = doPat locn pat
 229
 230 doName locn rdr
 231   = newGlobalName locn Nothing rdr `thenRn` \ name ->
 232     returnRn (unitBag (RnName name))
 233 \end{code}
 234
 235 *********************************************************
 236 *                                                       *
 237 \subsection{Creating a new global name}
 238 *                                                       *
 239 *********************************************************
 240
 241 \begin{code}
 242 newGlobalName :: SrcLoc -> Maybe ExportFlag
 243               -> RdrName -> RnM_Info s Name
 244
 245 -- ToDo: b_names and b_keys being defined in this module !!!
 246
 247 newGlobalName locn maybe_exp rdr
 248   = getExtraRn                  `thenRn` \ (_,b_keys,exp_fn,occ_fn) ->
 249     getModuleRn                 `thenRn` \ mod ->
 250     rnGetUnique                 `thenRn` \ u ->
 251     let
 252         (uniq, unqual)
 253           = case rdr of
 254               Qual m n -> (u, n)
 255               Unqual n -> case (lookupFM b_keys n) of
 256                             Nothing      -> (u,   n)
 257                             Just (key,_) -> (key, n)
 258
 259         orig   = if fromPrelude mod
 260                  then (Unqual unqual)
 261                  else (Qual mod unqual)
 262
 263         exp = case maybe_exp of
 264                Just exp -> exp
 265                Nothing  -> exp_fn n
 266
 267         n = mkTopLevName uniq orig locn exp (occ_fn n)
 268     in
 269     addErrIfRn (isQual rdr) (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
 270     returnRn n
 271 \end{code}
 272
 273 *********************************************************
 274 *                                                       *
 275 \subsection{Imported names}
 276 *                                                       *
 277 *********************************************************
 278
 279 \begin{code}
 280 type ImportNameInfo = (GlobalNameInfo,
 281                        FiniteMap (Module,FAST_STRING) RnName,   -- values imported so far
 282                        FiniteMap (Module,FAST_STRING) RnName,   -- tycons/classes imported so far
 283                        Name -> ExportFlag)                      -- import flag
 284
 285 type RnM_IInfo s r = RnMonad ImportNameInfo s r
 286
 287 doImportDecls ::
 288            IfaceCache
 289         -> GlobalNameInfo                       -- builtin and knot name info
 290         -> UniqSupply
 291         -> [RdrNameImportDecl]                  -- import declarations
 292         -> IO (Bag (RdrName,RnName),            -- imported values in scope
 293                Bag (RdrName,RnName),            -- imported tycons/classes in scope
 294                [Module],                        -- directly imported modules
 295                Bag (Module,RnName),             -- unqualified import from module
 296                Bag RenamedFixityDecl,           -- fixity info for imported names
 297                Bag Error,
 298                Bag Warning)
 299
 300 doImportDecls iface_cache g_info us src_imps
 301   = fixIO ( \ ~(_, _, _, _, _, _, rec_imp_flags) ->
 302         let
 303             rec_imp_fm = addListToUFM_C lubExportFlag emptyUFM (bagToList rec_imp_flags)
 304
 305             rec_imp_fn :: Name -> ExportFlag
 306             rec_imp_fn n = case lookupUFM rec_imp_fm n of
 307                              Nothing   -> panic "RnNames:rec_imp_fn"
 308                              Just flag -> flag
 309
 310             i_info = (g_info, emptyFM, emptyFM, rec_imp_fn)
 311         in
 312         doImports iface_cache i_info us (qprel_imp ++ prel_imp ++ src_imps)
 313     ) >>= \ (vals, tcs, unquals, fixes, errs, warns, _) ->
 314     let
 315         imp_mods      = [ mod | ImportDecl mod _ _ _ _ <- src_imps ]
 316         imp_warns     = listToBag (map dupImportWarn imp_dups)
 317         prel_warns    = listToBag (map qualPreludeImportWarn qual_prels)
 318
 319         (_, imp_dups) = removeDups cmp_mod src_imps
 320         cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2
 321         qual_prels = [imp | imp@(ImportDecl mod qual _ _ _) <- src_imps,
 322                             fromPrelude mod && qual]
 323     in
 324     return (vals, tcs, imp_mods, unquals, fixes, errs,
 325             prel_warns `unionBags` imp_warns `unionBags` warns)
 326   where
 327     explicit_prelude_import
 328       = null [() | (ImportDecl mod qual _ _ _) <- src_imps,
 329                    fromPrelude mod && not qual]
 330
 331     qprel_imp = if opt_NoImplicitPrelude
 332                 then [{-the flag really means it: *NO* implicit "import Prelude" -}]
 333                 else [ImportDecl pRELUDE True Nothing Nothing mkIfaceSrcLoc]
 334
 335     prel_imp  = if not explicit_prelude_import || opt_NoImplicitPrelude
 336                 then
 337                    [ {-prelude imported explicitly => no import Prelude-} ]
 338                 else
 339                    [ImportDecl pRELUDE False Nothing Nothing mkIfaceSrcLoc]
 340
 341 doImports iface_cache i_info us []
 342   = return (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag)
 343 doImports iface_cache i_info@(g_info,done_vals,done_tcs,imp_fn) us (imp:imps)
 344   = doImport iface_cache i_info us1 imp
 345         >>= \ (vals1, tcs1, unquals1, fixes1, errs1, warns1, imps1) ->
 346     let
 347         new_vals = [ (moduleNamePair rn, rn) | (_,rn) <- bagToList vals1,
 348                         not (maybeToBool (lookupFM done_vals (moduleNamePair rn))) ]
 349                         -- moduleNamePair computed twice
 350         ext_vals = addListToFM done_vals new_vals
 351
 352         new_tcs  = [ (moduleNamePair rn, rn) | (_,rn) <- bagToList tcs1,
 353                         not (maybeToBool (lookupFM done_tcs (moduleNamePair rn))) ]
 354         ext_tcs  = addListToFM done_tcs new_tcs
 355     in
 356     doImports iface_cache (g_info,ext_vals,ext_tcs,imp_fn) us2 imps
 357         >>= \ (vals2, tcs2, unquals2, fixes2, errs2, warns2, imps2) ->
 358     return (vals1    `unionBags` vals2,
 359             tcs1     `unionBags` tcs2,
 360             unquals1 `unionBags` unquals2,
 361             fixes1   `unionBags` fixes2,
 362             errs1    `unionBags` errs2,
 363             warns1   `unionBags` warns2,
 364             imps1    `unionBags` imps2)
 365   where
 366     (us1, us2) = splitUniqSupply us
 367
 368
 369 doImport :: IfaceCache
 370          -> ImportNameInfo
 371          -> UniqSupply
 372          -> RdrNameImportDecl
 373          -> IO (Bag (RdrName,RnName),           -- values
 374                 Bag (RdrName,RnName),           -- tycons/classes
 375                 Bag (Module,RnName),            -- unqual imports
 376                 Bag RenamedFixityDecl,
 377                 Bag Error,
 378                 Bag Warning,
 379                 Bag (RnName,ExportFlag))        -- import flags
 380
 381 doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
 382   = cachedIface iface_cache mod         >>= \ maybe_iface ->
 383     case maybe_iface of
 384       Failed err ->
 385         return (emptyBag, emptyBag, emptyBag, emptyBag,
 386                 unitBag err, emptyBag, emptyBag)
 387       Succeeded iface ->
 388         let
 389             (b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec
 390             (ies, chk_ies, get_errs)     = getOrigIEs iface maybe_spec'
 391         in
 392         doOrigIEs iface_cache info mod src_loc us ies
 393                 >>= \ (ie_vals, ie_tcs, imp_flags, errs, warns) ->
 394         accumulate (map (checkOrigIE iface_cache) chk_ies)
 395                 >>= \ chk_errs_warns ->
 396         accumulate (map (getFixityDecl iface_cache) (bagToList ie_vals))
 397                 >>= \ fix_maybes_errs ->
 398         let
 399             (chk_errs, chk_warns)  = unzip chk_errs_warns
 400             (fix_maybes, fix_errs) = unzip fix_maybes_errs
 401
 402             final_vals = mapBag fst_occ b_vals `unionBags` mapBag pair_occ ie_vals
 403             final_tcs  = mapBag fst_occ b_tcs  `unionBags` mapBag pair_occ ie_tcs
 404
 405             unquals    = if qual then emptyBag
 406                          else mapBag pair_as (ie_vals `unionBags` ie_tcs)
 407
 408             final_fixes = listToBag (catMaybes fix_maybes)
 409
 410             final_errs  = mapBag (\ err -> err mod src_loc) (unionManyBags (get_errs:chk_errs))
 411                           `unionBags` errs `unionBags` unionManyBags fix_errs
 412             final_warns = mapBag (\ warn -> warn mod src_loc) (unionManyBags chk_warns)
 413                           `unionBags` warns
 414         in
 415         return (final_vals, final_tcs, unquals, final_fixes,
 416                 final_errs, final_warns, imp_flags)
 417   where
 418     as_mod = case maybe_as of {Nothing -> mod; Just as_this -> as_this}
 419     mk_occ str = if qual then Qual as_mod str else Unqual str
 420
 421     fst_occ (str, rn) = (mk_occ str, rn)
 422     pair_occ rn       = (mk_occ (getLocalName rn), rn)
 423     pair_as  rn       = (as_mod, rn)
 424
 425
 426 getBuiltins info mod maybe_spec
 427   | not (fromPrelude mod)
 428   = (emptyBag, emptyBag, maybe_spec)
 429
 430 getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec
 431   = case maybe_spec of
 432       Nothing           -> (all_vals, all_tcs, Nothing)
 433
 434       Just (True, ies)  -> -- hiding does not work for builtin names
 435                            (all_vals, all_tcs, maybe_spec)
 436
 437       Just (False, ies) -> let
 438                               (vals,tcs,ies_left) = do_builtin ies
 439                            in
 440                            (vals, tcs, Just (False, ies_left))
 441   where
 442     all_vals = do_all_builtin (fmToList b_val_names)
 443     all_tcs  = do_all_builtin (fmToList b_tc_names)
 444
 445     do_all_builtin [] = emptyBag
 446     do_all_builtin ((str,rn):rest)
 447       = (str, rn) `consBag` do_all_builtin rest
 448
 449     do_builtin [] = (emptyBag,emptyBag,[])
 450     do_builtin (ie:ies)
 451       = let str = unqual_str (ie_name ie)
 452         in
 453         case (lookupFM b_tc_names str) of -- NB: we favour the tycon/class FM...
 454           Just rn -> case (ie,rn) of
 455              (IEThingAbs _, WiredInTyCon tc)
 456                 -> (vals, (str, rn) `consBag` tcs, ies_left)
 457              (IEThingAll _, WiredInTyCon tc)
 458                 -> (listToBag (map (\ id -> (getLocalName id, WiredInId id))
 459                                    (tyConDataCons tc))
 460                     `unionBags` vals,
 461                     (str,rn) `consBag` tcs, ies_left)
 462              _ -> panic "importing builtin names (1)"
 463
 464           Nothing ->
 465             case (lookupFM b_val_names str) of
 466               Nothing -> (vals, tcs, ie:ies_left)
 467               Just rn -> case (ie,rn) of
 468                  (IEVar _, WiredInId _)
 469                     -> ((str, rn) `consBag` vals, tcs, ies_left)
 470                  _ -> panic "importing builtin names (2)"
 471       where
 472         (vals, tcs, ies_left) = do_builtin ies
 473
 474
 475 getOrigIEs (ParsedIface _ _ _ _ exps _ _ _ _ _ _) Nothing               -- import all
 476   = (map mkAllIE (eltsFM exps), [], emptyBag)
 477
 478 getOrigIEs (ParsedIface _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies))    -- import hiding
 479   = (map mkAllIE (eltsFM exps_left), found_ies, errs)
 480   where
 481     (found_ies, errs) = lookupIEs exps ies
 482     exps_left = delListFromFM exps (map (getLocalName.ie_name.fst) found_ies)
 483
 484 getOrigNames (ParsedIface _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies))
 485   = (map fst found_ies, found_ies, errs)
 486   where
 487     (found_ies, errs) = lookupIEs exps ies
 488
 489
 490 mkAllIE (orig,ExportAbs)
 491   = ASSERT(isLexCon (getLocalName orig))
 492     IEThingAbs orig
 493 mkAllIE (orig, ExportAll)
 494   | isLexCon (getLocalName orig)
 495   = IEThingAll orig
 496   | otherwise
 497   = IEVar orig
 498
 499
 500 lookupIEs exps []
 501   = ([], emptyBag)
 502 lookupIEs exps (ie:ies)
 503   = case lookupFM exps (unqual_str (ie_name ie)) of
 504       Nothing ->
 505         (orig_ies, unknownImpSpecErr ie `consBag` errs)
 506       Just (orig,flag) ->
 507         (orig_ie orig flag ie ++ orig_ies,
 508          adderr_if (seen_ie orig orig_ies) (duplicateImpSpecErr ie) errs)
 509   where
 510     (orig_ies, errs) = lookupIEs exps ies
 511
 512     orig_ie orig flag (IEVar n)          = [(IEVar orig, flag)]
 513     orig_ie orig flag (IEThingAbs n)     = [(IEThingAbs orig, flag)]
 514     orig_ie orig flag (IEThingAll n)     = [(IEThingAll orig, flag)]
 515     orig_ie orig flag (IEThingWith n ns) = [(IEThingWith orig ns, flag)]
 516
 517     seen_ie orig seen_ies = any (\ (ie,_) -> orig == ie_name ie) seen_ies
 518
 519
 520 doOrigIEs iface_cache info mod src_loc us []
 521   = return (emptyBag,emptyBag,emptyBag,emptyBag,emptyBag)
 522
 523 doOrigIEs iface_cache info mod src_loc us (ie:ies)
 524   = doOrigIE iface_cache info mod src_loc us1 ie
 525         >>= \ (vals1, tcs1, errs1, warns1, imps1) ->
 526     doOrigIEs iface_cache info mod src_loc us2 ies
 527         >>= \ (vals2, tcs2, errs2, warns2, imps2) ->
 528     return (vals1    `unionBags` vals2,
 529             tcs1     `unionBags` tcs2,
 530             errs1    `unionBags` errs2,
 531             warns1   `unionBags` warns2,
 532             imps1    `unionBags` imps2)
 533   where
 534     (us1, us2) = splitUniqSupply us
 535
 536 doOrigIE iface_cache info mod src_loc us ie
 537   = with_decl iface_cache (ie_name ie)
 538         (\ err  -> (emptyBag, emptyBag, emptyBag, unitBag err, emptyBag))
 539         (\ decl -> case initRn True mod emptyRnEnv us
 540                                (setExtraRn info $
 541                                 pushSrcLocRn src_loc $
 542                                 getIfaceDeclNames ie decl)
 543                    of
 544                    ((vals, tcs, imps), errs, warns) -> (vals, tcs, imps, errs, warns))
 545
 546 checkOrigIE iface_cache (IEThingAll n, ExportAbs)
 547   = with_decl iface_cache n
 548         (\ err  -> (unitBag (\ mod locn -> err), emptyBag))
 549         (\ decl -> case decl of
 550                 TypeSig _ _ _ -> (emptyBag, unitBag (allWhenSynImpSpecWarn n))
 551                 other         -> (unitBag (allWhenAbsImpSpecErr n), emptyBag))
 552
 553 checkOrigIE iface_cache (IEThingWith n ns, ExportAbs)
 554   = return (unitBag (withWhenAbsImpSpecErr n), emptyBag)
 555
 556 checkOrigIE iface_cache (IEThingWith n ns, ExportAll)
 557   = with_decl iface_cache n
 558         (\ err  -> (unitBag (\ mod locn -> err), emptyBag))
 559         (\ decl -> case decl of
 560                 NewTypeSig _ con _ _  -> (check_with "constructrs" [con] ns, emptyBag)
 561                 DataSig    _ cons _ _ -> (check_with "constructrs" cons  ns, emptyBag)
 562                 ClassSig   _ ops _ _  -> (check_with "class ops"   ops   ns, emptyBag))
 563   where
 564     check_with str has rdrs
 565       | sortLt (<) (map getLocalName has) == sortLt (<) (map unqual_str rdrs)
 566       = emptyBag
 567       | otherwise
 568       = unitBag (withImpSpecErr str n has rdrs)
 569
 570 checkOrigIE iface_cache other
 571   = return (emptyBag, emptyBag)
 572
 573
 574 with_decl iface_cache n do_err do_decl
 575   = cachedDecl iface_cache (isRdrLexCon n) n   >>= \ maybe_decl ->
 576     case maybe_decl of
 577       Failed err     -> return (do_err err)
 578       Succeeded decl -> return (do_decl decl)
 579
 580
 581 getFixityDecl iface_cache rn
 582   = let
 583         (mod, str) = moduleNamePair rn
 584     in
 585     cachedIface iface_cache mod >>= \ maybe_iface ->
 586     case maybe_iface of
 587       Failed err ->
 588         return (Nothing, unitBag err)
 589       Succeeded (ParsedIface _ _ _ _ _ _ fixes _ _ _ _) ->
 590         case lookupFM fixes str of
 591           Nothing           -> return (Nothing, emptyBag)
 592           Just (InfixL _ i) -> return (Just (InfixL rn i), emptyBag)
 593           Just (InfixR _ i) -> return (Just (InfixR rn i), emptyBag)
 594           Just (InfixN _ i) -> return (Just (InfixN rn i), emptyBag)
 595
 596 ie_name (IEVar n)         = n
 597 ie_name (IEThingAbs n)    = n
 598 ie_name (IEThingAll n)    = n
 599 ie_name (IEThingWith n _) = n
 600
 601 unqual_str (Unqual str) = str
 602 unqual_str q@(Qual _ _) = panic "unqual_str"
 603
 604 adderr_if True err errs  = err `consBag` errs
 605 adderr_if False err errs = errs
 606 \end{code}
 607
 608 *********************************************************
 609 *                                                       *
 610 \subsection{Actually creating the imported names}
 611 *                                                       *
 612 *********************************************************
 613
 614 \begin{code}
 615 getIfaceDeclNames :: RdrNameIE -> RdrIfaceDecl
 616                   -> RnM_IInfo s (Bag RnName,                   -- values
 617                                   Bag RnName,                   -- tycons/classes
 618                                   Bag (RnName,ExportFlag))      -- import flags
 619
 620 getIfaceDeclNames ie (ValSig val src_loc _)
 621   = newImportedName False src_loc Nothing Nothing val `thenRn` \ val_name ->
 622     returnRn (unitBag (RnName val_name),
 623               emptyBag,
 624               unitBag (RnName val_name, ExportAll))
 625
 626 getIfaceDeclNames ie (TypeSig tycon src_loc _)
 627   = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
 628     returnRn (emptyBag,
 629               unitBag (RnSyn tycon_name),
 630               unitBag (RnSyn tycon_name, ExportAll))
 631
 632 getIfaceDeclNames ie (NewTypeSig tycon con src_loc _)
 633   = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
 634     mapRn (newImportedName False src_loc (Just (nameExportFlag tycon_name))
 635                                          (Just (nameImportFlag tycon_name)))
 636                                             [con] `thenRn` \ con_names ->
 637     returnRn (if imp_all (imp_flag ie) then
 638                   listToBag (map (\ n -> RnConstr n tycon_name) con_names)
 639               else
 640                   emptyBag,
 641               unitBag (RnData tycon_name con_names),
 642               unitBag (RnData tycon_name con_names, imp_flag ie))
 643
 644 getIfaceDeclNames ie (DataSig tycon cons src_loc _)
 645   = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
 646     mapRn (newImportedName False src_loc (Just (nameExportFlag tycon_name))
 647                                          (Just (nameImportFlag tycon_name)))
 648                                              cons `thenRn` \ con_names ->
 649     returnRn (if imp_all (imp_flag ie) then
 650                   listToBag (map (\ n -> RnConstr n tycon_name) con_names)
 651               else
 652                   emptyBag,
 653               unitBag (RnData tycon_name con_names),
 654               unitBag (RnData tycon_name con_names, imp_flag ie))
 655
 656 getIfaceDeclNames ie (ClassSig cls ops src_loc _)
 657   = newImportedName True src_loc Nothing Nothing cls `thenRn` \ cls_name ->
 658     mapRn (newImportedName False src_loc (Just (nameExportFlag cls_name))
 659                                          (Just (nameImportFlag cls_name)))
 660                                             ops `thenRn` \ op_names ->
 661     returnRn (if imp_all (imp_flag ie) then
 662                   listToBag (map (\ n -> RnClassOp n cls_name) op_names)
 663               else
 664                   emptyBag,
 665               unitBag (RnClass cls_name op_names),
 666               unitBag (RnClass cls_name op_names, imp_flag ie))
 667
 668
 669 imp_all ExportAll = True
 670 imp_all _         = False
 671
 672 imp_flag (IEThingAbs _)    = ExportAbs
 673 imp_flag (IEThingAll _)    = ExportAll
 674 imp_flag (IEThingWith _ _) = ExportAll
 675 \end{code}
 676
 677 *********************************************************
 678 *                                                       *
 679 \subsection{Creating a new imported name}
 680 *                                                       *
 681 *********************************************************
 682
 683 \begin{code}
 684 newImportedName :: Bool                 -- True => tycon or class
 685                 -> SrcLoc
 686                 -> Maybe ExportFlag     -- maybe export flag
 687                 -> Maybe ExportFlag     -- maybe import flag
 688                 -> RdrName              -- orig name
 689                 -> RnM_IInfo s Name
 690
 691 newImportedName tycon_or_class locn maybe_exp maybe_imp rdr
 692   = getExtraRn `thenRn` \ ((_,b_keys,exp_fn,occ_fn),done_vals,done_tcs,imp_fn) ->
 693     case if tycon_or_class
 694          then lookupFM done_tcs  (moduleNamePair rdr)
 695          else lookupFM done_vals (moduleNamePair rdr)
 696     of
 697     Just rn -> returnRn (getName rn)
 698     Nothing ->
 699         rnGetUnique     `thenRn` \ u ->
 700         let
 701             uniq = case rdr of
 702                      Qual m n -> u
 703                      Unqual n -> case lookupFM b_keys n of
 704                                    Nothing      -> u
 705                                    Just (key,_) -> key
 706
 707             exp  = case maybe_exp of
 708                      Just exp -> exp
 709                      Nothing  -> exp_fn n
 710
 711             imp  = case maybe_imp of
 712                      Just imp -> imp
 713                      Nothing  -> imp_fn n
 714
 715             n = mkImportedName uniq rdr imp locn exp (occ_fn n)
 716         in
 717         returnRn n
 718 \end{code}
 719
 720 \begin{code}
 721 globalDupNamesErr rdr rns sty
 722   = ppHang (ppBesides [pprNonSym sty rdr, ppStr " multiply defined:"])
 723          4 (ppAboves (map pp_def rns))
 724   where
 725     pp_def rn = addShortErrLocLine (getSrcLoc rn) (\ sty -> ppr sty rn) sty
 726
 727 dupImportWarn dup_imps sty
 728   = ppStr "dupImportWarn"
 729
 730 qualPreludeImportWarn imp sty
 731   = ppStr "qualPreludeImportWarn"
 732
 733 unknownImpSpecErr ie imp_mod locn sty
 734   = ppStr "unknownImpSpecErr"
 735
 736 duplicateImpSpecErr ie imp_mod locn sty
 737   = ppStr "duplicateImpSpecErr"
 738
 739 allWhenSynImpSpecWarn n imp_mod locn sty
 740   = ppStr "allWhenSynImpSpecWarn"
 741
 742 allWhenAbsImpSpecErr n imp_mod locn sty
 743   = ppStr "allWhenAbsImpSpecErr"
 744
 745 withWhenAbsImpSpecErr n imp_mod locn sty
 746   = ppStr "withWhenAbsImpSpecErr"
 747
 748 withImpSpecErr str n has ns imp_mod locn sty
 749   = ppStr "withImpSpecErr"
 750 \end{code}