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