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