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