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