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