ghc/compiler/rename/RenameMonad4.lhs

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