ghc/compiler/rename/RnMonad.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[RnMonad]{The monad used by the renamer}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module RnMonad (
  10         RnMonad(..), RnM(..), RnM_Fixes(..), RnDown, SST_R,
  11         initRn, thenRn, thenRn_, andRn, returnRn,
  12         mapRn, mapAndUnzipRn,
  13
  14         addErrRn, addErrIfRn, addWarnRn, addWarnIfRn,
  15         failButContinueRn, warnAndContinueRn,
  16         setExtraRn, getExtraRn,
  17         getModuleRn, pushSrcLocRn, getSrcLocRn,
  18         getSourceRn, getOccurrenceUpRn,
  19         getImplicitUpRn, ImplicitEnv(..),
  20         rnGetUnique, rnGetUniques,
  21
  22         newLocalNames,
  23         lookupValue, lookupValueMaybe,
  24         lookupTyCon, lookupClass, lookupClassOp,
  25         extendSS2, extendSS,
  26
  27         TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv,
  28         lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs
  29     ) where
  30
  31 import Ubiq{-uitous-}
  32
  33 import SST
  34
  35 import HsSyn            ( FixityDecl )
  36 import RnHsSyn          ( RnName, mkRnName, mkRnUnbound, mkRnImplicit,
  37                           mkRnImplicitTyCon, mkRnImplicitClass,
  38                           isRnLocal, isRnWired, isRnTyCon, isRnClass, isRnClassOp,
  39                           RenamedFixityDecl(..) )
  40 import RnUtils          ( RnEnv(..), extendLocalRnEnv,
  41                           lookupRnEnv, lookupTcRnEnv,
  42                           unknownNameErr, badClassOpErr, qualNameErr,
  43                           dupNamesErr, shadowedNameWarn )
  44
  45 import Bag              ( Bag, emptyBag, isEmptyBag, snocBag )
  46 import CmdLineOpts      ( opt_WarnNameShadowing )
  47 import ErrUtils         ( Error(..), Warning(..) )
  48 import FiniteMap        ( FiniteMap, emptyFM, lookupFM, addToFM )
  49 import Maybes           ( assocMaybe )
  50 import Name             ( Module(..), RdrName(..), isQual,
  51                           Name, mkLocalName, mkImplicitName,
  52                           getOccName
  53                         )
  54 import Pretty           ( Pretty(..), PrettyRep )
  55 import SrcLoc           ( SrcLoc, mkUnknownSrcLoc )
  56 import UniqFM           ( UniqFM, emptyUFM )
  57 import UniqSet          ( UniqSet(..), mkUniqSet, minusUniqSet )
  58 import UniqSupply       ( UniqSupply, getUnique, getUniques, splitUniqSupply )
  59 import Unique           ( Unique )
  60 import Util
  61
  62 infixr 9 `thenRn`, `thenRn_`
  63 \end{code}
  64
  65 \begin{code}
  66 type RnM s r       = RnMonad () s r
  67 type RnM_Fixes s r = RnMonad (UniqFM RenamedFixityDecl) s r
  68
  69 type RnMonad x s r = RnDown x s -> SST s r
  70
  71 data RnDown x s
  72   = RnDown
  73         x
  74         Module                          -- Module name
  75         SrcLoc                          -- Source location
  76         (RnMode s)                      -- Source or Iface
  77         RnEnv                           -- Renaming environment
  78         (MutableVar s UniqSupply)       -- Unique supply
  79         (MutableVar s (Bag Warning,     -- Warnings and Errors
  80                        Bag Error))
  81
  82 data RnMode s
  83  = RnSource (MutableVar s (Bag (RnName, RdrName)))
  84         -- Renaming source; returning occurences
  85
  86  | RnIface  (MutableVar s ImplicitEnv)
  87         -- Renaming interface; creating and returning implicit names
  88         -- One map for Values and one for TyCons/Classes.
  89
  90 type ImplicitEnv = (FiniteMap RdrName RnName, FiniteMap RdrName RnName)
  91
  92
  93 -- With a builtin polymorphic type for _runSST the type for
  94 -- initTc should use  RnM s r  instead of  RnM _RealWorld r
  95
  96 initRn :: Bool          -- True => Source; False => Iface
  97        -> Module
  98        -> RnEnv
  99        -> UniqSupply
 100        -> RnM _RealWorld r
 101        -> (r, Bag Error, Bag Warning)
 102
 103 initRn source mod env us do_rn
 104   = _runSST (
 105         newMutVarSST emptyBag                   `thenSST` \ occ_var ->
 106         newMutVarSST (emptyFM,emptyFM)          `thenSST` \ imp_var ->
 107         newMutVarSST us                         `thenSST` \ us_var ->
 108         newMutVarSST (emptyBag,emptyBag)        `thenSST` \ errs_var ->
 109         let
 110             mode = if source then
 111                        RnSource occ_var
 112                    else
 113                        RnIface imp_var
 114
 115             rn_down = RnDown () mod mkUnknownSrcLoc mode env us_var errs_var
 116         in
 117         -- do the buisness
 118         do_rn rn_down                           `thenSST` \ res ->
 119
 120         -- grab errors and return
 121         readMutVarSST errs_var                  `thenSST` \ (warns,errs) ->
 122         returnSST (res, errs, warns)
 123     )
 124
 125 {-# INLINE thenRn #-}
 126 {-# INLINE thenRn_ #-}
 127 {-# INLINE returnRn #-}
 128 {-# INLINE andRn #-}
 129
 130 returnRn :: a -> RnMonad x s a
 131 thenRn   :: RnMonad x s a -> (a -> RnMonad x s b) -> RnMonad x s b
 132 thenRn_  :: RnMonad x s a -> RnMonad x s b -> RnMonad x s b
 133 andRn    :: (a -> a -> a) -> RnMonad x s a -> RnMonad x s a -> RnMonad x s a
 134 mapRn    :: (a -> RnMonad x s b) -> [a] -> RnMonad x s [b]
 135 mapAndUnzipRn :: (a -> RnMonad x s (b,c)) -> [a] -> RnMonad x s ([b],[c])
 136
 137 returnRn v down  = returnSST v
 138 thenRn m k down  = m down `thenSST` \ r -> k r down
 139 thenRn_ m k down = m down `thenSST_` k down
 140
 141 andRn combiner m1 m2 down
 142   = m1 down `thenSST` \ res1 ->
 143     m2 down `thenSST` \ res2 ->
 144     returnSST (combiner res1 res2)
 145
 146 mapRn f []     = returnRn []
 147 mapRn f (x:xs)
 148   = f x         `thenRn` \ r ->
 149     mapRn f xs  `thenRn` \ rs ->
 150     returnRn (r:rs)
 151
 152 mapAndUnzipRn f [] = returnRn ([],[])
 153 mapAndUnzipRn f (x:xs)
 154   = f x                 `thenRn` \ (r1,  r2)  ->
 155     mapAndUnzipRn f xs  `thenRn` \ (rs1, rs2) ->
 156     returnRn (r1:rs1, r2:rs2)
 157 \end{code}
 158
 159 For errors and warnings ...
 160 \begin{code}
 161 failButContinueRn :: a -> Error -> RnMonad x s a
 162 failButContinueRn res err (RnDown _ _ _ _ _ _ errs_var)
 163   = readMutVarSST  errs_var                             `thenSST`  \ (warns,errs) ->
 164     writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
 165     returnSST res
 166
 167 warnAndContinueRn :: a -> Warning -> RnMonad x s a
 168 warnAndContinueRn res warn (RnDown _ _ _ _ _ _ errs_var)
 169   = readMutVarSST  errs_var                              `thenSST`  \ (warns,errs) ->
 170     writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
 171     returnSST res
 172
 173 addErrRn :: Error -> RnMonad x s ()
 174 addErrRn err = failButContinueRn () err
 175
 176 addErrIfRn :: Bool -> Error -> RnMonad x s ()
 177 addErrIfRn True err  = addErrRn err
 178 addErrIfRn False err = returnRn ()
 179
 180 addWarnRn :: Warning -> RnMonad x s ()
 181 addWarnRn warn = warnAndContinueRn () warn
 182
 183 addWarnIfRn :: Bool -> Warning -> RnMonad x s ()
 184 addWarnIfRn True warn  = addWarnRn warn
 185 addWarnIfRn False warn = returnRn ()
 186 \end{code}
 187
 188
 189 \begin{code}
 190 setExtraRn :: x -> RnMonad x s r -> RnMonad y s r
 191 setExtraRn x m (RnDown _ mod locn mode env us errs)
 192   = m (RnDown x mod locn mode env us errs)
 193
 194 getExtraRn :: RnMonad x s x
 195 getExtraRn (RnDown x _ _ _ _ _ _)
 196   = returnSST x
 197
 198 getModuleRn :: RnMonad x s Module
 199 getModuleRn (RnDown _ mod _ _ _ _ _)
 200   = returnSST mod
 201
 202 pushSrcLocRn :: SrcLoc -> RnMonad x s a -> RnMonad x s a
 203 pushSrcLocRn locn m (RnDown x mod _ mode env us errs)
 204   = m (RnDown x mod locn mode env us errs)
 205
 206 getSrcLocRn :: RnMonad x s SrcLoc
 207 getSrcLocRn (RnDown _ _ locn _ _ _ _)
 208   = returnSST locn
 209
 210 getSourceRn :: RnMonad x s Bool
 211 getSourceRn (RnDown _ _ _ (RnSource _) _ _ _) = returnSST True
 212 getSourceRn (RnDown _ _ _ (RnIface  _) _ _ _) = returnSST False
 213
 214 getOccurrenceUpRn :: RnMonad x s (Bag (RnName, RdrName))
 215 getOccurrenceUpRn (RnDown _ _ _ (RnSource occ_var) _ _ _)
 216   = readMutVarSST occ_var
 217 getOccurrenceUpRn (RnDown _ _ _ (RnIface _) _ _ _)
 218   = panic "getOccurrenceUpRn:RnIface"
 219
 220 getImplicitUpRn :: RnMonad x s (FiniteMap RdrName RnName, FiniteMap RdrName RnName)
 221 getImplicitUpRn (RnDown _ _ _ (RnIface imp_var) _ _ _)
 222   = readMutVarSST imp_var
 223 getImplicitUpRn (RnDown _ _ _(RnSource _) _ _ _)
 224   = panic "getImplicitUpRn:RnIface"
 225 \end{code}
 226
 227 \begin{code}
 228 rnGetUnique :: RnMonad x s Unique
 229 rnGetUnique (RnDown _ _ _ _ _ us_var _)
 230   = get_unique us_var
 231
 232 rnGetUniques :: Int -> RnMonad x s [Unique]
 233 rnGetUniques n (RnDown _ _ _ _ _ us_var _)
 234   = get_uniques n us_var
 235
 236
 237 get_unique us_var
 238   = readMutVarSST us_var                        `thenSST` \ uniq_supply ->
 239     let
 240       (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 241       uniq                      = getUnique uniq_s
 242     in
 243     writeMutVarSST us_var new_uniq_supply       `thenSST_`
 244     returnSST uniq
 245
 246 get_uniques n us_var
 247   = readMutVarSST us_var                        `thenSST` \ uniq_supply ->
 248     let
 249       (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 250       uniqs                     = getUniques n uniq_s
 251     in
 252     writeMutVarSST us_var new_uniq_supply       `thenSST_`
 253     returnSST uniqs
 254
 255 snoc_bag_var add bag_var
 256   = readMutVarSST bag_var       `thenSST` \ bag ->
 257     writeMutVarSST bag_var (bag `snocBag` add)
 258
 259 \end{code}
 260
 261 *********************************************************
 262 *                                                       *
 263 \subsection{Making new names}
 264 *                                                       *
 265 *********************************************************
 266
 267 @newLocalNames@ takes a bunch of RdrNames, which are defined together
 268 in a group (eg a pattern or set of bindings), checks they are
 269 unqualified and distinct, and creates new Names for them.
 270
 271 \begin{code}
 272 newLocalNames :: String                 -- Documentation string
 273               -> [(RdrName, SrcLoc)]
 274               -> RnMonad x s [RnName]
 275
 276 newLocalNames str names_w_loc
 277   = mapRn (addErrRn . qualNameErr str) quals `thenRn_`
 278     mapRn (addErrRn . dupNamesErr str) dups  `thenRn_`
 279     mkLocalNames these
 280   where
 281     quals         = filter (isQual.fst) names_w_loc
 282     (these, dups) = removeDups cmp_fst names_w_loc
 283     cmp_fst (a,_) (b,_) = cmp a b
 284 \end{code}
 285
 286 \begin{code}
 287 mkLocalNames :: [(RdrName, SrcLoc)] -> RnMonad x s [RnName]
 288 mkLocalNames names_w_locs
 289   = rnGetUniques (length names_w_locs)  `thenRn` \ uniqs ->
 290     returnRn (zipWithEqual new_local uniqs names_w_locs)
 291   where
 292     new_local uniq (Unqual str, srcloc)
 293       = mkRnName (mkLocalName uniq str srcloc)
 294 \end{code}
 295
 296
 297 *********************************************************
 298 *                                                       *
 299 \subsection{Looking up values}
 300 *                                                       *
 301 *********************************************************
 302
 303 Action to look up a value depends on the RnMode.
 304 \begin{description}
 305 \item[RnSource:]
 306 Lookup value in RnEnv, recording occurrence for non-local values found.
 307 If not found report error and return Unbound name.
 308 \item[RnIface:]
 309 Lookup value in RnEnv. If not found lookup in implicit name env.
 310 If not found create new implicit name, adding it to the implicit env.
 311 \end{description}
 312
 313 \begin{code}
 314 lookupValue      :: RdrName -> RnMonad x s RnName
 315 lookupClassOp    :: RnName  -> RdrName -> RnMonad x s RnName
 316
 317 lookupValue rdr
 318   = lookup_val rdr (\ rn -> True) (unknownNameErr "value")
 319
 320 lookupClassOp cls rdr
 321   = lookup_val rdr (isRnClassOp cls) (badClassOpErr cls)
 322
 323
 324 lookup_val rdr check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _)
 325   = case lookupRnEnv env rdr of
 326         Just name | check name -> succ name
 327                   | otherwise   -> fail
 328         Nothing                -> fail
 329
 330   where
 331     succ name = if isRnLocal name || isRnWired name then
 332                     returnSST name
 333                 else
 334                     snoc_bag_var (name,rdr) occ_var `thenSST_`
 335                     returnSST name
 336     fail = failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down
 337
 338 lookup_val rdr check do_err down@(RnDown _ _ locn (RnIface imp_var) env us_var _)
 339   = case lookupRnEnv env rdr of
 340         Just name | check name -> returnSST name
 341                   | otherwise  -> failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down
 342         Nothing                -> lookup_or_create_implicit_val imp_var us_var rdr
 343
 344 lookup_or_create_implicit_val imp_var us_var rdr
 345   = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm)->
 346     case lookupFM implicit_val_fm rdr of
 347         Just implicit -> returnSST implicit
 348         Nothing ->
 349             get_unique us_var                   `thenSST` \ uniq ->
 350             let
 351                 implicit   = mkRnImplicit (mkImplicitName uniq rdr)
 352                 new_val_fm = addToFM implicit_val_fm rdr implicit
 353             in
 354             writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_`
 355             returnSST implicit
 356
 357
 358 lookupValueMaybe :: RdrName -> RnMonad x s (Maybe RnName)
 359 lookupValueMaybe rdr down@(RnDown _ _ _ (RnSource _) env _ _)
 360   = returnSST (lookupRnEnv env rdr)
 361 \end{code}
 362
 363
 364 \begin{code}
 365 lookupTyCon   :: RdrName -> RnMonad x s RnName
 366 lookupClass   :: RdrName -> RnMonad x s RnName
 367
 368 lookupTyCon rdr
 369   = lookup_tc rdr isRnTyCon mkRnImplicitTyCon "type constructor"
 370
 371 lookupClass rdr
 372   = lookup_tc rdr isRnClass mkRnImplicitClass "class"
 373
 374
 375 lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnSource occ_var) env _ _)
 376   = case lookupTcRnEnv env rdr of
 377        Just name | check name -> succ name
 378                  | otherwise  -> fail
 379        Nothing                -> fail
 380   where
 381     succ name = snoc_bag_var (name,rdr) occ_var `thenSST_`
 382                 returnSST name
 383     fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
 384
 385 lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnIface imp_var) env us_var _)
 386   = case lookupTcRnEnv env rdr of
 387         Just name | check name -> returnSST name
 388                   | otherwise  -> fail
 389         Nothing -> lookup_or_create_implicit_tc check mk_implicit fail imp_var us_var rdr
 390   where
 391     fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
 392
 393 lookup_or_create_implicit_tc check mk_implicit fail imp_var us_var rdr
 394   = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm)->
 395     case lookupFM implicit_tc_fm rdr of
 396         Just implicit | check implicit -> returnSST implicit
 397                       | otherwise      -> fail
 398         Nothing ->
 399             get_unique us_var                   `thenSST` \ uniq ->
 400             let
 401                 implicit  = mk_implicit (mkImplicitName uniq rdr)
 402                 new_tc_fm = addToFM implicit_tc_fm rdr implicit
 403             in
 404             writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) `thenSST_`
 405             returnSST implicit
 406 \end{code}
 407
 408
 409 @extendSS@ extends the scope; @extendSS2@ also removes the newly bound
 410 free vars from the result.
 411
 412 \begin{code}
 413 extendSS :: [RnName]                            -- Newly bound names
 414          -> RnMonad x s a
 415          -> RnMonad x s a
 416
 417 extendSS binders m down@(RnDown x mod locn mode env us errs)
 418   = (mapRn (addErrRn . shadowedNameWarn locn) dups `thenRn_`
 419      m) (RnDown x mod locn mode new_env us errs)
 420   where
 421     (new_env,dups) = extendLocalRnEnv opt_WarnNameShadowing env binders
 422
 423 extendSS2 :: [RnName]                           -- Newly bound names
 424           -> RnMonad x s (a, UniqSet RnName)
 425           -> RnMonad x s (a, UniqSet RnName)
 426
 427 extendSS2 binders m
 428   = extendSS binders m `thenRn` \ (r, fvs) ->
 429     returnRn (r, fvs `minusUniqSet` (mkUniqSet binders))
 430 \end{code}
 431
 432 The free var set returned by @(extendSS binders m)@ is that returned
 433 by @m@, {\em minus} binders.
 434
 435
 436 *********************************************************
 437 *                                                       *
 438 \subsection{TyVarNamesEnv}
 439 *                                                       *
 440 *********************************************************
 441
 442 \begin{code}
 443 type TyVarNamesEnv = [(RdrName, RnName)]
 444
 445 nullTyVarNamesEnv :: TyVarNamesEnv
 446 nullTyVarNamesEnv = []
 447
 448 catTyVarNamesEnvs :: TyVarNamesEnv -> TyVarNamesEnv -> TyVarNamesEnv
 449 catTyVarNamesEnvs e1 e2 = e1 ++ e2
 450
 451 domTyVarNamesEnv :: TyVarNamesEnv -> [RdrName]
 452 domTyVarNamesEnv env = map fst env
 453 \end{code}
 454
 455 @mkTyVarNamesEnv@ checks for duplicates, and complains if so.
 456
 457 \begin{code}
 458 mkTyVarNamesEnv
 459         :: SrcLoc
 460         -> [RdrName]                            -- The type variables
 461         -> RnMonad x s (TyVarNamesEnv,[RnName]) -- Environment and renamed tyvars
 462
 463 mkTyVarNamesEnv src_loc tyvars
 464   = newLocalNames "type variable"
 465          (tyvars `zip` repeat src_loc) `thenRn`  \ rn_tyvars ->
 466
 467          -- rn_tyvars may not be in the same order as tyvars, so we need some
 468          -- jiggery pokery to build the right tyvar env, and return the
 469          -- renamed tyvars in the original order.
 470     let tv_occ_name_pairs       = map tv_occ_name_pair rn_tyvars
 471         tv_env                  = map (lookup_occ_name tv_occ_name_pairs) tyvars
 472         rn_tyvars_in_orig_order = map snd tv_env
 473     in
 474     returnRn (tv_env, rn_tyvars_in_orig_order)
 475   where
 476     tv_occ_name_pair :: RnName -> (RdrName, RnName)
 477     tv_occ_name_pair rn_name = (getOccName rn_name, rn_name)
 478
 479     lookup_occ_name :: [(RdrName, RnName)] -> RdrName -> (RdrName, RnName)
 480     lookup_occ_name pairs tyvar_occ
 481       = (tyvar_occ, assoc "mkTyVarNamesEnv" pairs tyvar_occ)
 482 \end{code}
 483
 484 \begin{code}
 485 lookupTyVarName :: TyVarNamesEnv -> RdrName -> RnMonad x s RnName
 486 lookupTyVarName env occ
 487   = case (assocMaybe env occ) of
 488       Just name -> returnRn name
 489       Nothing   -> getSrcLocRn  `thenRn` \ loc ->
 490                    failButContinueRn (mkRnUnbound occ)
 491                        (unknownNameErr "type variable" occ loc)
 492 \end{code}