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     ( returnPrimIO, thenPrimIO, MutableVar(..) )
  15
  16 import Ubiq
  17
  18 import HsSyn
  19 import RdrHsSyn
  20 import RnHsSyn
  21
  22 import ParseIface       ( ParsedIface )
  23 import RnMonad
  24 import RnIfaces         ( IfaceCache(..), cachedIface )
  25 import RnUtils          ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv, qualNameErr, dupNamesErr )
  26
  27 import Bag              ( emptyBag, unitBag, unionBags, unionManyBags, mapBag, listToBag, bagToList )
  28 import ErrUtils         ( Error(..), Warning(..), addShortErrLocLine )
  29 import FiniteMap        ( fmToList )
  30 import Name             ( RdrName(..), Name, isQual, mkTopLevName,
  31                           mkImportedName, nameExportFlag,
  32                           getLocalName, getSrcLoc, pprNonOp
  33                         )
  34 import PrelInfo         ( BuiltinNames(..), BuiltinKeys(..) )
  35 import PrelMods         ( fromPrelude )
  36 import Pretty
  37 import SrcLoc           ( SrcLoc )
  38 import UniqSupply       ( splitUniqSupply )
  39 import Util             ( equivClasses, panic )
  40 \end{code}
  41
  42
  43 \begin{code}
  44 type GlobalNameInfo = (BuiltinNames,
  45                        BuiltinKeys,
  46                        Name -> ExportFlag,
  47                        Name -> [RdrName])
  48
  49 type RnM_Info s r = RnMonad GlobalNameInfo s r
  50
  51 getGlobalNames ::
  52            IfaceCache
  53         -> GlobalNameInfo
  54         -> UniqSupply
  55         -> RdrNameHsModule
  56         -> PrimIO (RnEnv,
  57                    [Module],                            -- directly imported modules
  58                    Bag (Module,(RnName,ExportFlag)),    -- unqualified imports from module
  59                    Bag RenamedFixityDecl,               -- imported fixity decls
  60                    Bag Error,
  61                    Bag Warning)
  62
  63 getGlobalNames iface_var info us
  64                (HsModule mod _ _ imports _ ty_decls _ cls_decls _ _ _ binds _ _)
  65   = case initRn True mod emptyRnEnv us1
  66                 (setExtraRn info $
  67                  getSourceNames ty_decls cls_decls binds)
  68     of { ((src_vals, src_tcs), src_errs, src_warns) ->
  69
  70     getImportedNames iface_var info us2 imports `thenPrimIO`
  71         \ (imp_vals, imp_tcs, imp_mods, unqual_imps, imp_fixes, imp_errs, imp_warns) ->
  72
  73     let
  74         unqual_vals = mapBag (\rn -> (Unqual (getLocalName rn), rn)) src_vals
  75         unqual_tcs  = mapBag (\rn -> (Unqual (getLocalName rn), rn)) src_tcs
  76
  77         all_vals = bagToList (unqual_vals `unionBags` imp_vals)
  78         all_tcs  = bagToList (unqual_tcs  `unionBags` imp_tcs)
  79
  80         (all_env, dups) = extendGlobalRnEnv emptyRnEnv all_vals all_tcs
  81
  82         dup_errs = map dup_err (equivClasses cmp_rdr (bagToList dups))
  83         cmp_rdr (rdr1,_,_) (rdr2,_,_) = cmp rdr1 rdr2
  84         dup_err ((rdr,rn,rn'):rest) = globalDupNamesErr rdr (rn:rn': [rn|(_,_,rn)<-rest])
  85
  86         all_errs  = src_errs `unionBags` imp_errs `unionBags` listToBag dup_errs
  87         all_warns = src_warns `unionBags` imp_warns
  88     in
  89     returnPrimIO (all_env, bagToList imp_mods, unqual_imps, imp_fixes, all_errs, all_warns)
  90     }
  91   where
  92     (us1, us2) = splitUniqSupply us
  93 \end{code}
  94
  95 *********************************************************
  96 *                                                       *
  97 \subsection{Top-level source names}
  98 *                                                       *
  99 *********************************************************
 100
 101 \begin{code}
 102 getSourceNames ::
 103            [RdrNameTyDecl]
 104         -> [RdrNameClassDecl]
 105         -> RdrNameHsBinds
 106         -> RnM_Info s (Bag RnName,      -- values
 107                        Bag RnName)      -- tycons/classes
 108
 109 getSourceNames ty_decls cls_decls binds
 110   = mapAndUnzipRn getTyDeclNames ty_decls   `thenRn` \ (tycon_s, constrs_s) ->
 111     mapAndUnzipRn getClassNames cls_decls  `thenRn` \ (cls_s, cls_ops_s) ->
 112     getTopBindsNames binds                         `thenRn` \ bind_names ->
 113     returnRn (unionManyBags constrs_s `unionBags`
 114               unionManyBags cls_ops_s `unionBags` bind_names,
 115               listToBag tycon_s `unionBags` listToBag cls_s)
 116
 117
 118 getTyDeclNames :: RdrNameTyDecl
 119                -> RnM_Info s (RnName, Bag RnName)       -- tycon and constrs
 120
 121 getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc)
 122   = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
 123     mapRn (getConDeclName (Just (nameExportFlag tycon_name)))
 124                                condecls `thenRn` \ con_names ->
 125     returnRn (RnData tycon_name con_names,
 126               listToBag (map (\ n -> RnConstr n tycon_name) con_names))
 127
 128 getTyDeclNames (TyNew _ tycon _ condecls _ _ src_loc)
 129   = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
 130     mapRn (getConDeclName (Just (nameExportFlag tycon_name)))
 131                                condecls `thenRn` \ con_names ->
 132     returnRn (RnData tycon_name con_names,
 133               listToBag (map (\ n -> RnConstr n tycon_name) con_names))
 134
 135 getTyDeclNames (TySynonym tycon _ _ src_loc)
 136   = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
 137     returnRn (RnSyn tycon_name, emptyBag)
 138
 139 getConDeclName exp (ConDecl con _ src_loc)
 140   = newGlobalName src_loc exp con
 141 getConDeclName exp (ConOpDecl _ op _ src_loc)
 142   = newGlobalName src_loc exp op
 143 getConDeclName exp (NewConDecl con _ src_loc)
 144   = newGlobalName src_loc exp con
 145 getConDeclName exp (RecConDecl con fields src_loc)
 146   = panic "getConDeclName:RecConDecl"
 147     newGlobalName src_loc exp con
 148
 149
 150 getClassNames :: RdrNameClassDecl
 151               -> RnM_Info s (RnName, Bag RnName)        -- class and class ops
 152
 153 getClassNames (ClassDecl _ cname _ sigs _ _ src_loc)
 154   = newGlobalName src_loc Nothing cname `thenRn` \ class_name ->
 155     getClassOpNames (Just (nameExportFlag class_name))
 156                                   sigs  `thenRn` \ op_names ->
 157     returnRn (RnClass class_name op_names,
 158               listToBag (map (\ n -> RnClassOp n class_name) op_names))
 159
 160 getClassOpNames exp []
 161   = returnRn []
 162 getClassOpNames exp (ClassOpSig op _ _ src_loc : sigs)
 163   = newGlobalName src_loc exp op `thenRn` \ op_name ->
 164     getClassOpNames exp sigs     `thenRn` \ op_names ->
 165     returnRn (op_name : op_names)
 166 getClassOpNames exp (_ : sigs)
 167   = getClassOpNames exp sigs
 168 \end{code}
 169
 170 *********************************************************
 171 *                                                       *
 172 \subsection{Bindings}
 173 *                                                       *
 174 *********************************************************
 175
 176 \begin{code}
 177 getTopBindsNames :: RdrNameHsBinds
 178                  -> RnM_Info s (Bag RnName)
 179
 180 getTopBindsNames binds = doBinds binds
 181
 182 doBinds EmptyBinds           = returnRn emptyBag
 183 doBinds (SingleBind bind)    = doBind bind
 184 doBinds (BindWith bind sigs) = doBind bind
 185 doBinds (ThenBinds binds1 binds2)
 186   = andRn unionBags (doBinds binds1) (doBinds binds2)
 187
 188 doBind EmptyBind          = returnRn emptyBag
 189 doBind (NonRecBind mbind) = doMBinds mbind
 190 doBind (RecBind mbind)    = doMBinds mbind
 191
 192 doMBinds EmptyMonoBinds                         = returnRn emptyBag
 193 doMBinds (PatMonoBind pat grhss_and_binds locn) = doPat locn pat
 194 doMBinds (FunMonoBind p_name _ _ locn)          = doName locn p_name
 195 doMBinds (AndMonoBinds mbinds1 mbinds2)
 196   = andRn unionBags (doMBinds mbinds1) (doMBinds mbinds2)
 197
 198 doPats locn pats
 199   = mapRn (doPat locn) pats     `thenRn` \ pats_s ->
 200     returnRn (unionManyBags pats_s)
 201
 202 doPat locn WildPatIn             = returnRn emptyBag
 203 doPat locn (LitPatIn _)          = returnRn emptyBag
 204 doPat locn (LazyPatIn pat)       = doPat locn pat
 205 doPat locn (VarPatIn var)        = doName locn var
 206 doPat locn (NegPatIn pat)        = doPat locn pat
 207 doPat locn (ParPatIn pat)        = doPat locn pat
 208 doPat locn (ListPatIn pats)      = doPats locn pats
 209 doPat locn (TuplePatIn pats)     = doPats locn pats
 210 doPat locn (ConPatIn name pats)  = doPats locn pats
 211 doPat locn (ConOpPatIn p1 op p2)
 212   = andRn unionBags (doPat locn p1) (doPat locn p2)
 213 doPat locn (AsPatIn as_name pat)
 214   = andRn unionBags (doName locn as_name) (doPat locn pat)
 215 doPat locn (RecPatIn name fields)
 216   = mapRn (doField locn) fields `thenRn` \ fields_s ->
 217     returnRn (unionManyBags fields_s)
 218
 219 doField locn (_, pat, _) = doPat locn pat
 220
 221 doName locn rdr
 222   = newGlobalName locn Nothing rdr `thenRn` \ name ->
 223     returnRn (unitBag (RnName name))
 224 \end{code}
 225
 226 *********************************************************
 227 *                                                       *
 228 \subsection{Creating a new global name}
 229 *                                                       *
 230 *********************************************************
 231
 232 \begin{code}
 233 newGlobalName :: SrcLoc -> Maybe ExportFlag
 234               -> RdrName -> RnM_Info s Name
 235
 236 newGlobalName locn maybe_exp rdr
 237   = getExtraRn                  `thenRn` \ (_,_,exp_fn,occ_fn) ->
 238     getModuleRn                 `thenRn` \ mod ->
 239     getSourceRn                 `thenRn` \ source ->
 240     rnGetUnique                 `thenRn` \ u ->
 241     let
 242         src_unqual = getLocalName rdr
 243
 244         src_orig   = if fromPrelude mod
 245                      then (Unqual src_unqual)
 246                      else (Qual mod src_unqual)
 247
 248         exp = case maybe_exp of
 249                Just exp -> exp
 250                Nothing  -> exp_fn n
 251
 252         n = if source then
 253                 mkTopLevName u src_orig locn exp (occ_fn n)
 254             else
 255                 mkImportedName u rdr locn exp (occ_fn n)
 256     in
 257     addErrIfRn (source && isQual rdr)
 258                (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
 259     returnRn n
 260 \end{code}
 261
 262 *********************************************************
 263 *                                                       *
 264 \subsection{Imported names}
 265 *                                                       *
 266 *********************************************************
 267
 268 \begin{code}
 269 getImportedNames ::
 270            IfaceCache
 271         -> GlobalNameInfo                               -- builtin and knot name info
 272         -> UniqSupply
 273         -> [RdrNameImportDecl]                          -- import declarations
 274         -> PrimIO (Bag (RdrName,RnName),                -- imported values in scope
 275                    Bag (RdrName,RnName),                -- imported tycons/classes in scope
 276                    Bag Module,                          -- directly imported modules
 277                    Bag (Module,(RnName,ExportFlag)),    -- unqualified imports from module
 278                    Bag RenamedFixityDecl,               -- fixity info for imported names
 279                    Bag Error,
 280                    Bag Warning)
 281
 282 getImportedNames iface_var info us imports
 283   = returnPrimIO (builtin_vals, builtin_tcs, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag)
 284   where
 285     -- For now jsut add the builtin names ...
 286     (b_names,_,_,_) = info
 287     builtin_vals = listToBag [(Unqual s, rn) | (s,rn) <- fmToList b_names, not (isRnTyCon rn)]
 288     builtin_tcs  = listToBag [(Unqual s, rn) | (s,rn) <- fmToList b_names, isRnTyCon rn]
 289 \end{code}
 290
 291
 292 \begin{code}
 293 globalDupNamesErr rdr rns sty
 294   = ppHang (ppBesides [pprNonOp sty rdr, ppStr " multiply defined:"])
 295          4 (ppAboves (map pp_def rns))
 296   where
 297     pp_def rn = addShortErrLocLine (getSrcLoc rn) (\ sty -> ppr sty rn) sty
 298
 299     -- ToDo: print import src locs for imported names
 300 \end{code}