ghc/compiler/rename/RnMonad4.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[RnMonad4]{The monad used by the fourth renamer pass}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module RnMonad4 (
  10         Rn4M(..),
  11         initRn4, thenRn4, thenRn4_, andRn4, returnRn4, mapRn4, mapAndUnzipRn4,
  12         addErrRn4, failButContinueRn4, recoverQuietlyRn4,
  13         pushSrcLocRn4,
  14         getSrcLocRn4,
  15         lookupValue, lookupValueEvenIfInvisible,
  16         lookupClassOp, lookupFixityOp,
  17         lookupTyCon, lookupTyConEvenIfInvisible,
  18         lookupClass,
  19         extendSS2, extendSS,
  20         namesFromProtoNames,
  21
  22         TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv,
  23         lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs
  24
  25         -- for completeness
  26     ) where
  27
  28 import Ubiq{-uitous-}
  29
  30 import Bag              ( emptyBag, isEmptyBag, unionBags, snocBag, Bag )
  31 import CmdLineOpts      ( opt_ShowPragmaNameErrs, opt_NameShadowingNotOK )
  32 import ErrUtils
  33 import FiniteMap        ( emptyFM, addListToFM, addToFM, lookupFM )
  34 import Name             ( invisibleName, isTyConName, isClassName,
  35                           isClassOpName, isUnboundName, Name(..)
  36                         )
  37 import NameTypes        ( mkShortName, ShortName{-instances-} )
  38 import Outputable       ( pprNonOp )
  39 import Pretty
  40 import ProtoName        ( eqProtoName, cmpByLocalName, ProtoName(..) )
  41 import RnUtils          ( dupNamesErr, GlobalNameMappers(..) )
  42 import SrcLoc           ( mkUnknownSrcLoc, SrcLoc{-instance-} )
  43 import UniqSet          ( mkUniqSet, minusUniqSet, UniqSet(..) )
  44 import UniqSupply       ( getUniques, splitUniqSupply )
  45 import Util             ( assoc, removeDups, zipWithEqual, panic )
  46
  47 infixr 9 `thenRn4`, `thenRn4_`
  48 \end{code}
  49
  50 %************************************************************************
  51 %*                                                                      *
  52 \subsection[RnMonad4]{Plain @Rename@ monadery for pass~4}
  53 %*                                                                      *
  54 %************************************************************************
  55
  56 \begin{code}
  57 type ScopeStack = FiniteMap FAST_STRING Name
  58
  59 type Rn4M result
  60   =  GlobalNameMappers
  61   -> ScopeStack
  62   -> Bag Error
  63   -> UniqSupply
  64   -> SrcLoc
  65   -> (result, Bag Error)
  66
  67 {-# INLINE andRn4 #-}
  68 {-# INLINE thenRn4 #-}
  69 {-# INLINE thenLazilyRn4 #-}
  70 {-# INLINE thenRn4_ #-}
  71 {-# INLINE returnRn4 #-}
  72
  73 initRn4 :: GlobalNameMappers
  74         -> Rn4M result
  75         -> UniqSupply
  76         -> (result, Bag Error)
  77
  78 initRn4 gnfs renamer init_us
  79   = renamer gnfs emptyFM emptyBag init_us mkUnknownSrcLoc
  80
  81 thenRn4, thenLazilyRn4
  82          :: Rn4M a -> (a -> Rn4M b) -> Rn4M b
  83 thenRn4_ :: Rn4M a -> Rn4M b -> Rn4M b
  84 andRn4   :: (a -> a -> a) -> Rn4M a -> Rn4M a -> Rn4M a
  85
  86 thenRn4 expr cont gnfs ss errs uniqs locn
  87   = case (splitUniqSupply uniqs)           of { (s1, s2) ->
  88     case (expr      gnfs ss errs  s1 locn) of { (res1, errs1) ->
  89     case (cont res1 gnfs ss errs1 s2 locn) of { (res2, errs2) ->
  90     (res2, errs2) }}}
  91
  92 thenLazilyRn4 expr cont gnfs ss errs uniqs locn
  93   = let
  94         (s1, s2)      = splitUniqSupply uniqs
  95         (res1, errs1) = expr      gnfs ss errs  s1 locn
  96         (res2, errs2) = cont res1 gnfs ss errs1 s2 locn
  97     in
  98     (res2, errs2)
  99
 100 thenRn4_ expr cont gnfs ss errs uniqs locn
 101   = case (splitUniqSupply uniqs)      of { (s1, s2) ->
 102     case (expr gnfs ss errs  s1 locn) of { (_,    errs1) ->
 103     case (cont gnfs ss errs1 s2 locn) of { (res2, errs2) ->
 104     (res2, errs2) }}}
 105
 106 andRn4 combiner m1 m2 gnfs ss errs us locn
 107   = case (splitUniqSupply us)       of { (s1, s2) ->
 108     case (m1 gnfs ss errs  s1 locn) of { (res1, errs1) ->
 109     case (m2 gnfs ss errs1 s2 locn) of { (res2, errs2) ->
 110     (combiner res1 res2, errs2) }}}
 111
 112 returnRn4 :: a -> Rn4M a
 113 returnRn4 result gnfs ss errs_so_far uniqs locn
 114    = (result, errs_so_far)
 115
 116 failButContinueRn4 :: a -> Error -> Rn4M a
 117 failButContinueRn4 res err gnfs ss errs_so_far uniqs locn
 118   = (res, errs_so_far `snocBag` err)
 119
 120 addErrRn4 :: Error -> Rn4M ()
 121 addErrRn4 err gnfs ss errs_so_far uniqs locn
 122   = ((), errs_so_far `snocBag` err)
 123 \end{code}
 124
 125 When we're looking at interface pragmas, we want to be able to recover
 126 back to a ``I don't know anything pragmatic'' state if we encounter
 127 some problem.  @recoverQuietlyRn4@ is given a ``use-this-instead'' value,
 128 as well as the action to perform.  This code is intentionally very lazy,
 129 returning a triple immediately, no matter what.
 130 \begin{code}
 131 recoverQuietlyRn4 :: a -> Rn4M a -> Rn4M a
 132
 133 recoverQuietlyRn4 use_this_if_err action gnfs ss errs_so_far uniqs locn
 134   = let
 135         (result, errs_out)
 136           = case (action gnfs ss emptyBag{-leav out errs-} uniqs locn) of
 137               (result1, errs1) ->
 138                 if isEmptyBag errs1 then -- all's well! (but retain incoming errs)
 139                     (result1, errs_so_far)
 140                 else -- give up; return *incoming* UniqueSupply...
 141                     (use_this_if_err,
 142                      if opt_ShowPragmaNameErrs
 143                      then errs_so_far `unionBags` errs1
 144                      else errs_so_far) -- toss errs, otherwise
 145     in
 146     (result, errs_out)
 147 \end{code}
 148
 149 \begin{code}
 150 mapRn4 :: (a -> Rn4M b) -> [a] -> Rn4M [b]
 151
 152 mapRn4 f []     = returnRn4 []
 153 mapRn4 f (x:xs)
 154   = f x         `thenRn4` \ r ->
 155     mapRn4 f xs `thenRn4` \ rs ->
 156     returnRn4 (r:rs)
 157
 158 mapAndUnzipRn4  :: (a -> Rn4M (b,c))   -> [a] -> Rn4M ([b],[c])
 159
 160 mapAndUnzipRn4 f [] = returnRn4 ([],[])
 161 mapAndUnzipRn4 f (x:xs)
 162   = f x                 `thenRn4` \ (r1,  r2)  ->
 163     mapAndUnzipRn4 f xs `thenRn4` \ (rs1, rs2) ->
 164     returnRn4 (r1:rs1, r2:rs2)
 165 \end{code}
 166
 167 \begin{code}
 168 pushSrcLocRn4 :: SrcLoc -> Rn4M a -> Rn4M a
 169 pushSrcLocRn4 locn exp gnfs ss errs_so_far uniq_supply old_locn
 170   = exp gnfs ss errs_so_far uniq_supply locn
 171
 172 getSrcLocRn4 :: Rn4M SrcLoc
 173
 174 getSrcLocRn4 gnfs ss errs_so_far uniq_supply locn
 175   = returnRn4 locn gnfs ss errs_so_far uniq_supply locn
 176 \end{code}
 177
 178 \begin{code}
 179 getNextUniquesFromRn4 :: Int -> Rn4M [Unique]
 180 getNextUniquesFromRn4 n gnfs ss errs_so_far us locn
 181   = case (getUniques n us) of { next_uniques ->
 182     (next_uniques, errs_so_far) }
 183 \end{code}
 184
 185 *********************************************************
 186 *                                                       *
 187 \subsection{Making new names}
 188 *                                                       *
 189 *********************************************************
 190
 191 @namesFromProtoNames@ takes a bunch of protonames, which are defined
 192 together in a group (eg a pattern or set of bindings), checks they
 193 are distinct, and creates new full names for them.
 194
 195 \begin{code}
 196 namesFromProtoNames :: String           -- Documentation string
 197                     -> [(ProtoName, SrcLoc)]
 198                     -> Rn4M [Name]
 199
 200 namesFromProtoNames kind pnames_w_src_loc gnfs ss errs_so_far us locn
 201   = (mapRn4 (addErrRn4 . dupNamesErr kind) dups `thenRn4_`
 202     mkNewNames goodies
 203     ) {-Rn4-} gnfs ss errs_so_far us locn
 204   where
 205     (goodies, dups) = removeDups cmp pnames_w_src_loc
 206         -- We want to compare their local names rather than their
 207         -- full protonames.  It probably doesn't matter here, but it
 208         -- does in RnPass3.lhs!
 209     cmp (a, _) (b, _) = cmpByLocalName a b
 210 \end{code}
 211
 212 @mkNewNames@ assumes the names are unique.
 213
 214 \begin{code}
 215 mkNewNames :: [(ProtoName, SrcLoc)] -> Rn4M [Name]
 216 mkNewNames pnames_w_locs
 217   = getNextUniquesFromRn4 (length pnames_w_locs) `thenRn4` \ uniqs ->
 218     returnRn4 (zipWithEqual new_short_name uniqs pnames_w_locs)
 219   where
 220     new_short_name uniq (Unk str, srcloc)   -- gotta be an Unk...
 221       = Short uniq (mkShortName str srcloc)
 222 \end{code}
 223
 224
 225 *********************************************************
 226 *                                                       *
 227 \subsection{Local scope extension and lookup}
 228 *                                                       *
 229 *********************************************************
 230
 231 If the input name is an @Imp@, @lookupValue@ looks it up in the GNF.
 232 If it is an @Unk@, it looks it up first in the local environment
 233 (scope stack), and if it isn't found there, then in the value GNF.  If
 234 it isn't found at all, @lookupValue@ adds an error message, and
 235 returns an @Unbound@ name.
 236
 237 \begin{code}
 238 unboundName :: ProtoName -> Name
 239 unboundName pn
 240    = Unbound (grab_string pn)
 241    where
 242      grab_string (Unk  s)      = s
 243      grab_string (Qunk _ s)    = s
 244      grab_string (Imp _ _ _ s) = s
 245 \end{code}
 246
 247 @lookupValue@ looks up a non-invisible value;
 248 @lookupValueEvenIfInvisible@ gives a successful lookup even if the
 249 value is not visible to the user (e.g., came out of a pragma).
 250 @lookup_val@ is the help function to do the work.
 251
 252 \begin{code}
 253 lookupValue v {-Rn4-} gnfs ss errs_so_far us locn
 254   = (lookup_val v       `thenLazilyRn4` \ name ->
 255     if invisibleName name
 256     then failButContinueRn4 (unboundName v) (unknownNameErr "value" v mkUnknownSrcLoc)
 257     else returnRn4 name
 258     ) {-Rn4-} gnfs ss errs_so_far us locn
 259
 260 lookupValueEvenIfInvisible v = lookup_val v
 261
 262 lookup_val :: ProtoName -> Rn4M Name
 263
 264 lookup_val pname@(Unk v) gnfs@(v_gnf, tc_gnf) ss a b locn
 265   = case (lookupFM ss v) of
 266       Just name -> returnRn4 name gnfs ss a b locn
 267       Nothing   -> case (v_gnf pname) of
 268                      Just name  -> returnRn4 name gnfs ss a b locn
 269                      Nothing    -> failButContinueRn4 (unboundName pname)
 270                                            (unknownNameErr "value" pname locn)
 271                                            gnfs ss a b locn
 272
 273 lookup_val (Qunk _ _) _ _ _ _ _ = panic "RnMonad4:lookup_val:Qunk"
 274
 275 -- If it ain't an Unk it must be in the global name fun; that includes
 276 -- prelude things.
 277 lookup_val pname gnfs@(v_gnf, tc_gnf) ss a b locn
 278   = case (v_gnf pname) of
 279         Just name  -> returnRn4 name gnfs ss a b locn
 280         Nothing    -> failButContinueRn4 (unboundName pname)
 281                               (unknownNameErr "value" pname locn)
 282                               gnfs ss a b locn
 283 \end{code}
 284
 285 Looking up the operators in a fixity decl is done differently.  We
 286 want to simply drop any fixity decls which refer to operators which
 287 aren't in scope.  Unfortunately, such fixity decls {\em will} appear
 288 because the parser collects *all* the fixity decls from {\em all} the
 289 imported interfaces (regardless of selective import), and dumps them
 290 together as the module fixity decls.  This is really a bug.  In
 291 particular:
 292 \begin{itemize}
 293 \item
 294 We won't complain about fixity decls for operators which aren't
 295 declared.
 296 \item
 297 We won't attach the right fixity to something which has been renamed.
 298 \end{itemize}
 299
 300 We're not going to export Prelude-related fixities (ToDo: correctly),
 301 so we nuke those, too.
 302
 303 \begin{code}
 304 lookupFixityOp (Prel _) gnfs@(v_gnf, tc_gnf) = returnRn4 Nothing       gnfs
 305 lookupFixityOp pname    gnfs@(v_gnf, tc_gnf) = returnRn4 (v_gnf pname) gnfs
 306 \end{code}
 307
 308 \begin{code}
 309 lookupTyCon, lookupTyConEvenIfInvisible :: ProtoName -> Rn4M Name
 310 -- The global name funs handle Prel things
 311
 312 lookupTyCon tc {-Rn4-} gnfs ss errs_so_far us locn
 313   = (lookup_tycon tc `thenLazilyRn4` \ name ->
 314     if invisibleName name
 315     then failButContinueRn4 (unboundName tc) (unknownNameErr "type constructor" tc mkUnknownSrcLoc)
 316     else returnRn4 name
 317     ) {-Rn4-} gnfs ss errs_so_far us locn
 318
 319 lookupTyConEvenIfInvisible tc = lookup_tycon tc
 320
 321 lookup_tycon (Prel name) gnfs ss a b locn = returnRn4 name gnfs ss a b locn
 322
 323 lookup_tycon pname gnfs@(v_gnf, tc_gnf) ss a b locn
 324   = case (tc_gnf pname) of
 325      Just name | isTyConName name -> returnRn4 name gnfs ss a b locn
 326      _   -> failButContinueRn4 (unboundName pname)
 327                     (unknownNameErr "type constructor" pname locn)
 328                     gnfs ss a b locn
 329 \end{code}
 330
 331 \begin{code}
 332 lookupClass :: ProtoName -> Rn4M Name
 333
 334 lookupClass pname gnfs@(v_gnf, tc_gnf) ss a b locn
 335   = case (tc_gnf pname) of
 336      Just name | isClassName name -> returnRn4 name gnfs ss a b locn
 337      _   -> failButContinueRn4 (unboundName pname)
 338                     (unknownNameErr "class" pname locn)
 339                     gnfs ss a b locn
 340 \end{code}
 341
 342 @lookupClassOp@ is used when looking up the lhs identifiers in a class
 343 or instance decl.  It checks that the name it finds really is a class
 344 op, and that its class matches that of the class or instance decl
 345 being looked at.
 346
 347 \begin{code}
 348 lookupClassOp :: Name -> ProtoName -> Rn4M Name
 349
 350 lookupClassOp class_name pname gnfs@(v_gnf, tc_gnf) ss a b locn
 351   = case v_gnf pname of
 352          Just op_name |  isClassOpName class_name op_name
 353                       || isUnboundName class_name -- avoid spurious errors
 354                  -> returnRn4 op_name gnfs ss a b locn
 355
 356          other   -> failButContinueRn4 (unboundName pname)
 357                             (badClassOpErr class_name pname locn)
 358                             gnfs ss a b locn
 359 \end{code}
 360
 361 @extendSS@ extends the scope; @extendSS2@ also removes the newly bound
 362 free vars from the result.
 363
 364 \begin{code}
 365 extendSS :: [Name]                              -- Newly bound names
 366          -> Rn4M a
 367          -> Rn4M a
 368
 369 extendSS binders expr gnfs ss errs us locn
 370   = case (extend binders ss gnfs ss errs us locn) of { (new_ss, new_errs) ->
 371     expr gnfs new_ss new_errs us locn }
 372   where
 373     extend :: [Name] -> ScopeStack -> Rn4M ScopeStack
 374
 375     extend names ss
 376       = if opt_NameShadowingNotOK then
 377             hard_way names ss
 378         else -- ignore shadowing; blast 'em in
 379             returnRn4 (
 380                 addListToFM ss [ (getOccurrenceName x, n) | n@(Short _ x) <- names]
 381             )
 382
 383     hard_way [] ss = returnRn4 ss
 384     hard_way (name@(Short _ sname):names) ss
 385       = let
 386             str = getOccurrenceName sname
 387         in
 388         (case (lookupFM ss str) of
 389            Nothing -> returnRn4 (addToFM ss str name)
 390            Just  _ -> failButContinueRn4 ss (shadowedNameErr name locn)
 391
 392         )       `thenRn4` \ new_ss ->
 393         hard_way names new_ss
 394
 395 extendSS2 :: [Name]                             -- Newly bound names
 396          -> Rn4M (a, UniqSet Name)
 397          -> Rn4M (a, UniqSet Name)
 398
 399 extendSS2 binders expr gnfs ss errs_so_far us locn
 400   = case (extendSS binders expr gnfs ss errs_so_far us locn) of
 401      ((e2, freevars), errs)
 402        -> ((e2, freevars `minusUniqSet` (mkUniqSet binders)),
 403            errs)
 404 \end{code}
 405
 406 The free var set returned by @(extendSS binders m)@ is that returned
 407 by @m@, {\em minus} binders.
 408
 409 *********************************************************
 410 *                                                       *
 411 \subsection{mkTyVarNamesEnv}
 412 *                                                       *
 413 *********************************************************
 414
 415 \begin{code}
 416 type TyVarNamesEnv = [(ProtoName, Name)]
 417
 418 nullTyVarNamesEnv :: TyVarNamesEnv
 419 nullTyVarNamesEnv = []
 420
 421 catTyVarNamesEnvs :: TyVarNamesEnv -> TyVarNamesEnv -> TyVarNamesEnv
 422 catTyVarNamesEnvs e1 e2 = e1 ++ e2
 423
 424 domTyVarNamesEnv :: TyVarNamesEnv -> [ProtoName]
 425 domTyVarNamesEnv env = map fst env
 426 \end{code}
 427
 428 @mkTyVarNamesEnv@ checks for duplicates, and complains if so.
 429
 430 \begin{code}
 431 mkTyVarNamesEnv
 432         :: SrcLoc
 433         -> [ProtoName]                  -- The type variables
 434         -> Rn4M (TyVarNamesEnv,[Name])  -- Environment and renamed tyvars
 435
 436 mkTyVarNamesEnv src_loc tyvars {-Rn4-} gnfs ss errs_so_far us locn
 437   = (namesFromProtoNames "type variable"
 438          (tyvars `zip` repeat src_loc)  `thenRn4`  \ tyvars2 ->
 439
 440          -- tyvars2 may not be in the same order as tyvars, so we need some
 441          -- jiggery pokery to build the right tyvar env, and return the
 442          -- renamed tyvars in the original order.
 443     let tv_string_name_pairs    = extend tyvars2 []
 444         tv_env                  = map (lookup tv_string_name_pairs) tyvars
 445         tyvars2_in_orig_order   = map snd tv_env
 446     in
 447     returnRn4  (tv_env, tyvars2_in_orig_order)
 448     ) {-Rn4-} gnfs ss errs_so_far us locn
 449   where
 450     extend :: [Name] -> [(FAST_STRING, Name)] -> [(FAST_STRING, Name)]
 451     extend [] ss = ss
 452     extend (name@(Short _ sname):names) ss
 453       = (getOccurrenceName sname, name) : extend names ss
 454
 455     lookup :: [(FAST_STRING, Name)] -> ProtoName -> (ProtoName, Name)
 456     lookup pairs tyvar_pn
 457       = (tyvar_pn, assoc "mkTyVarNamesEnv" pairs (getOccurrenceName tyvar_pn))
 458 \end{code}
 459
 460 \begin{code}
 461 lookupTyVarName :: TyVarNamesEnv -> ProtoName -> Rn4M Name
 462 lookupTyVarName env pname {-Rn4-} gnfs ss errs_so_far us locn
 463   = (case (assoc_maybe env pname) of
 464      Just name -> returnRn4 name
 465      Nothing   -> getSrcLocRn4  `thenRn4` \ loc ->
 466                   failButContinueRn4 (unboundName pname)
 467                           (unknownNameErr "type variable" pname loc)
 468     ) {-Rn4-} gnfs ss errs_so_far us locn
 469   where
 470     assoc_maybe [] _ = Nothing
 471     assoc_maybe ((tv,xxx) : tvs) key
 472       = if tv `eqProtoName` key then Just xxx else assoc_maybe tvs key
 473 \end{code}
 474
 475 %************************************************************************
 476 %*                                                                      *
 477 \subsection{Error messages}
 478 %*                                                                      *
 479 %************************************************************************
 480
 481 \begin{code}
 482 badClassOpErr clas op locn
 483   = addErrLoc locn "" ( \ sty ->
 484     ppBesides [ppChar '`', pprNonOp sty op, ppStr "' is not an operation of class `",
 485               ppr sty clas, ppStr "'."] )
 486
 487 ----------------------------
 488 -- dupNamesErr: from RnUtils
 489
 490 ---------------------------
 491 shadowedNameErr shadow locn
 492   = addShortErrLocLine locn ( \ sty ->
 493     ppBesides [ppStr "more than one value with the same name (shadowing): ",
 494         ppr sty shadow] )
 495
 496 ------------------------------------------
 497 unknownNameErr descriptor undef_thing locn
 498   = addShortErrLocLine locn ( \ sty ->
 499     ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ",
 500         pprNonOp sty undef_thing] )
 501 \end{code}