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