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