ghc/compiler/rename/RnMonad.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1997
   3 %
   4 \section[RnMonad]{The monad used by the renamer}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module RnMonad(
  10         EXP_MODULE(RnMonad),
  11          -- close it up (partly done to allow unfoldings)
  12         EXP_MODULE(SST),
  13         SYN_IE(Module),
  14         FiniteMap,
  15         Bag,
  16         Name,
  17         SYN_IE(RdrNameHsDecl),
  18         SYN_IE(RdrNameInstDecl),
  19         SYN_IE(Version),
  20         SYN_IE(NameSet),
  21         OccName,
  22         Fixity
  23     ) where
  24
  25 IMP_Ubiq(){-uitous-}
  26
  27 import SST
  28 import PreludeGlaST     ( SYN_IE(ST), thenStrictlyST, returnStrictlyST )
  29
  30 import HsSyn
  31 import RdrHsSyn
  32 import ErrUtils         ( addErrLoc, addShortErrLocLine, addShortWarnLocLine,
  33                           pprBagOfErrors, SYN_IE(Error), SYN_IE(Warning)
  34                         )
  35 import Name             ( SYN_IE(Module), Name, OccName, Provenance, SYN_IE(NameSet), emptyNameSet,
  36                           isLocallyDefinedName,
  37                           modAndOcc, NamedThing(..)
  38                         )
  39 import CmdLineOpts      ( opt_D_show_rn_trace, opt_IgnoreIfacePragmas )
  40 import PrelInfo         ( builtinNames )
  41 import TyCon            ( TyCon {- instance NamedThing -} )
  42 import TysWiredIn       ( boolTyCon )
  43 import Pretty
  44 import PprStyle         ( PprStyle(..) )
  45 import SrcLoc           ( SrcLoc, mkGeneratedSrcLoc )
  46 import Unique           ( Unique )
  47 import FiniteMap        ( FiniteMap, emptyFM, bagToFM )
  48 import Bag              ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )
  49 import UniqSet
  50 import Util
  51
  52 infixr 9 `thenRn`, `thenRn_`
  53 \end{code}
  54
  55
  56 %************************************************************************
  57 %*                                                                      *
  58 \subsection{Somewhat magical interface to other monads}
  59 %*                                                                      *
  60 %************************************************************************
  61
  62 \begin{code}
  63 #if __GLASGOW_HASKELL__ >= 200
  64 # define REAL_WORLD RealWorld
  65 #else
  66 # define REAL_WORLD _RealWorld
  67 #endif
  68 \end{code}
  69
  70 \begin{code}
  71 sstToIO :: SST REAL_WORLD r -> IO r
  72 sstToIO sst
  73   = sstToST sst         `thenStrictlyST` \ r ->
  74     returnStrictlyST (Right r)
  75
  76 ioToRnMG :: IO r -> RnMG (Either IOError13 r)
  77 ioToRnMG io rn_down g_down = stToSST io
  78
  79 traceRn :: Pretty -> RnMG ()
  80 traceRn msg | opt_D_show_rn_trace = ioToRnMG (hPutStr stderr (ppShow 80 msg) >>
  81                                               hPutStr stderr "\n")      `thenRn_`
  82                                     returnRn ()
  83             | otherwise           = returnRn ()
  84 \end{code}
  85
  86
  87 %************************************************************************
  88 %*                                                                      *
  89 \subsection{Data types}
  90 %*                                                                      *
  91 %************************************************************************
  92
  93 ===================================================
  94                 MONAD TYPES
  95 ===================================================
  96
  97 \begin{code}
  98 type RnM s d r = RnDown s -> d -> SST s r
  99 type RnMS s r   = RnM s          (SDown s) r            -- Renaming source
 100 type RnMG r     = RnM REAL_WORLD GDown     r            -- Getting global names etc
 101 type MutVar a  = MutableVar REAL_WORLD a                -- ToDo: there ought to be a standard defn of this
 102
 103         -- Common part
 104 data RnDown s = RnDown
 105                   SrcLoc
 106                   (MutableVar s RnNameSupply)
 107                   (MutableVar s (Bag Warning, Bag Error))
 108                   (MutableVar s [(Name,Necessity)])             -- Occurrences
 109
 110 data Necessity = Compulsory | Optional          -- We *must* find definitions for
 111                                                 -- compulsory occurrences; we *may* find them
 112                                                 -- for optional ones.
 113
 114         -- For getting global names
 115 data GDown = GDown
 116                 SearchPath
 117                 (MutVar Ifaces)
 118
 119         -- For renaming source code
 120 data SDown s = SDown
 121                   RnEnv                 -- Global envt
 122                   NameEnv               -- Local name envt (includes global name envt,
 123                                         -- but may shadow it)
 124                   Module
 125                   RnSMode
 126
 127
 128 data RnSMode    = SourceMode
 129                 | InterfaceMode
 130
 131 type SearchPath = [String]              -- List of directories to seach for interface files
 132 type FreeVars   = NameSet
 133 \end{code}
 134
 135 ===================================================
 136                 ENVIRONMENTS
 137 ===================================================
 138
 139 \begin{code}
 140 type RnNameSupply = (UniqSupply, Int, FiniteMap (Module,OccName) Name)
 141         -- Ensures that one (m,n) pair gets one unique
 142         -- The Int is used to give a number to each instance declaration;
 143         -- it's really a separate name supply.
 144
 145 data RnEnv      = RnEnv NameEnv FixityEnv
 146 emptyRnEnv      = RnEnv emptyNameEnv emptyFixityEnv
 147
 148 type NameEnv    = FiniteMap RdrName Name
 149 emptyNameEnv    = emptyFM
 150
 151 type FixityEnv          = FiniteMap RdrName (Fixity, Provenance)
 152 emptyFixityEnv          = emptyFM
 153         -- It's possible to have a different fixity for B.op than for op:
 154         --
 155         --      module A( op ) where            module B where
 156         --      import qualified B( op )        infixr 2 op
 157         --      infixl 9 `op`                   op = ...
 158         --      op a b = a `B.op` b
 159
 160 data ExportEnv          = ExportEnv Avails Fixities
 161 type Avails             = [AvailInfo]
 162 type Fixities           = [(OccName, (Fixity, Provenance))]
 163         -- Can contain duplicates, if one module defines the same fixity,
 164         -- or the same type/class/id, more than once.   Hence a boring old list.
 165         -- This allows us to report duplicates in just one place, namely plusRnEnv.
 166
 167 type ModuleAvails       = FiniteMap Module Avails
 168
 169 data AvailInfo          = NotAvailable
 170                         | Avail Name            -- An ordinary identifier
 171                         | AvailTC Name          -- The name of the type or class
 172                                   [Name]        -- The available pieces of type/class. NB: If the type or
 173                                                 -- class is itself to be in scope, it must be in this list.
 174                                                 -- Thus, typically: Avail Eq [Eq, ==, /=]
 175 \end{code}
 176
 177 ===================================================
 178                 INTERFACE FILE STUFF
 179 ===================================================
 180
 181 \begin{code}
 182 type ExportItem          = (Module, [(OccName, [OccName])])
 183 type VersionInfo name    = [ImportVersion name]
 184 type ImportVersion name  = (Module, Version, [LocalVersion name])
 185 type LocalVersion name   = (name, Version)
 186
 187 data ParsedIface
 188   = ParsedIface
 189       Module                    -- Module name
 190       Version                   -- Module version number
 191       [ImportVersion OccName]           -- Usages
 192       [ExportItem]                      -- Exports
 193       [Module]                          -- Special instance modules
 194       [(OccName,Fixity)]                -- Fixities
 195       [(Version, RdrNameHsDecl)]        -- Local definitions
 196       [RdrNameInstDecl]                 -- Local instance declarations
 197
 198 type InterfaceDetails = (VersionInfo Name,      -- Version information
 199                          ExportEnv,             -- What this module exports
 200                          [Module])              -- Instance modules
 201
 202 type RdrNamePragma = ()                         -- Fudge for now
 203 -------------------
 204
 205 data Ifaces = Ifaces
 206                 Module                                                  -- Name of this module
 207                 (FiniteMap Module Version)
 208                 (FiniteMap Module (Avails, [(OccName,Fixity)]))         -- Exports
 209                 DeclsMap
 210
 211                 NameSet                 -- All the names (whether "big" or "small", whether wired-in or not,
 212                                         -- whether locally defined or not) that have been slurped in so far.
 213
 214                 [(Name,Version)]        -- All the (a) non-wired-in (b) "big" (c) non-locally-defined names that
 215                                         -- have been slurped in so far, with their versions.  Subset of
 216                                         -- the previous field.  This is used to generate the "usage" information
 217                                         -- for this module.
 218
 219                 (Bag IfaceInst)         -- Un-slurped instance decls; this bag is depleted when we
 220                                         -- slurp an instance decl so that we don't slurp the same one twice.
 221
 222                 [Module]                -- Set of modules with "special" instance declarations
 223                                         -- Excludes this module
 224
 225 type DeclsMap    = FiniteMap Name (Version, AvailInfo, RdrNameHsDecl)
 226 type IfaceInst   = ((Module, RdrNameInstDecl),  -- Instance decl
 227                     [Name])                     -- "Gate" names.  Slurp this instance decl when this
 228                                                 -- list becomes empty.  It's depleted whenever we
 229                                                 -- slurp another type or class decl.
 230 \end{code}
 231
 232
 233 %************************************************************************
 234 %*                                                                      *
 235 \subsection{Main monad code}
 236 %*                                                                      *
 237 %************************************************************************
 238
 239 \begin{code}
 240 initRn :: Module -> UniqSupply -> SearchPath -> SrcLoc
 241        -> RnMG r
 242        -> IO (r, Bag Error, Bag Warning)
 243
 244 initRn mod us dirs loc do_rn
 245   = sstToIO $
 246     newMutVarSST (us, 1, builtins)      `thenSST` \ names_var ->
 247     newMutVarSST (emptyBag,emptyBag)    `thenSST` \ errs_var ->
 248     newMutVarSST (emptyIfaces mod)      `thenSST` \ iface_var ->
 249     newMutVarSST initOccs               `thenSST` \ occs_var ->
 250     let
 251         rn_down = RnDown loc names_var errs_var occs_var
 252         g_down  = GDown dirs iface_var
 253     in
 254         -- do the buisness
 255     do_rn rn_down g_down                `thenSST` \ res ->
 256
 257         -- grab errors and return
 258     readMutVarSST errs_var                      `thenSST` \ (warns,errs) ->
 259     returnSST (res, errs, warns)
 260
 261
 262 initRnMS :: RnEnv -> Module -> RnSMode -> RnMS REAL_WORLD r -> RnMG r
 263 initRnMS rn_env@(RnEnv name_env _) mod_name mode m rn_down g_down
 264   = let
 265         s_down = SDown rn_env name_env mod_name mode
 266     in
 267     m rn_down s_down
 268
 269
 270 emptyIfaces :: Module -> Ifaces
 271 emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyFM emptyNameSet [] emptyBag []
 272
 273 builtins :: FiniteMap (Module,OccName) Name
 274 builtins = bagToFM (mapBag (\ name -> (modAndOcc name, name)) builtinNames)
 275
 276         -- Initial value for the occurrence pool.
 277 initOccs :: [(Name,Necessity)]
 278 initOccs = [(getName boolTyCon, Compulsory)]
 279         -- Booleans occur implicitly a lot, so it's tiresome to keep recording the fact, and
 280         -- rather implausible that not one will be used in the module.
 281         -- We could add some other common types, notably lists, but the general idea is
 282         -- to do as much as possible explicitly.
 283 \end{code}
 284
 285 \end{code}
 286
 287
 288 @renameSourceCode@ is used to rename stuff "out-of-line"; that is, not as part of
 289 the main renamer.  Examples: pragmas (which we don't want to rename unless
 290 we actually explore them); and derived definitions, which are only generated
 291 in the type checker.
 292
 293 The @RnNameSupply@ includes a @UniqueSupply@, so if you call it more than
 294 once you must either split it, or install a fresh unique supply.
 295
 296 \begin{code}
 297 renameSourceCode :: Module
 298                  -> RnNameSupply
 299                  -> RnMS REAL_WORLD r
 300                  -> r
 301
 302 -- Alas, we can't use the real runST, with the desired signature:
 303 --      renameSourceCode :: RnNameSupply -> RnMS s r -> r
 304 -- because we can't manufacture "new versions of runST".
 305
 306 renameSourceCode mod_name name_supply m
 307   = runSST (
 308         newMutVarSST name_supply                `thenSST` \ names_var ->
 309         newMutVarSST (emptyBag,emptyBag)        `thenSST` \ errs_var ->
 310         newMutVarSST []                         `thenSST` \ occs_var ->
 311         let
 312             rn_down = RnDown mkGeneratedSrcLoc names_var errs_var occs_var
 313             s_down = SDown emptyRnEnv emptyNameEnv mod_name InterfaceMode
 314         in
 315         m rn_down s_down                        `thenSST` \ result ->
 316
 317         readMutVarSST errs_var                  `thenSST` \ (warns,errs) ->
 318
 319         (if not (isEmptyBag errs) then
 320                 trace ("Urk! renameSourceCode found errors" ++ display errs)
 321          else if not (isEmptyBag warns) then
 322                 trace ("Urk! renameSourceCode found warnings" ++ display warns)
 323          else
 324                 id) $
 325
 326         returnSST result
 327     )
 328   where
 329     display errs = ppShow 80 (pprBagOfErrors PprDebug errs)
 330
 331 {-# INLINE thenRn #-}
 332 {-# INLINE thenRn_ #-}
 333 {-# INLINE returnRn #-}
 334 {-# INLINE andRn #-}
 335
 336 returnRn :: a -> RnM s d a
 337 thenRn   :: RnM s d a -> (a -> RnM s d b) -> RnM s d b
 338 thenRn_  :: RnM s d a -> RnM s d b -> RnM s d b
 339 andRn    :: (a -> a -> a) -> RnM s d a -> RnM s d a -> RnM s d a
 340 mapRn    :: (a -> RnM s d b) -> [a] -> RnM s d [b]
 341 sequenceRn :: [RnM s d a] -> RnM s d [a]
 342 foldlRn :: (b  -> a -> RnM s d b) -> b -> [a] -> RnM s d b
 343 mapAndUnzipRn :: (a -> RnM s d (b,c)) -> [a] -> RnM s d ([b],[c])
 344 fixRn    :: (a -> RnM s d a) -> RnM s d a
 345
 346 returnRn v gdown ldown  = returnSST v
 347 thenRn m k gdown ldown  = m gdown ldown `thenSST` \ r -> k r gdown ldown
 348 thenRn_ m k gdown ldown = m gdown ldown `thenSST_` k gdown ldown
 349 fixRn m gdown ldown = fixSST (\r -> m r gdown ldown)
 350 andRn combiner m1 m2 gdown ldown
 351   = m1 gdown ldown `thenSST` \ res1 ->
 352     m2 gdown ldown `thenSST` \ res2 ->
 353     returnSST (combiner res1 res2)
 354
 355 sequenceRn []     = returnRn []
 356 sequenceRn (m:ms) =  m                  `thenRn` \ r ->
 357                      sequenceRn ms      `thenRn` \ rs ->
 358                      returnRn (r:rs)
 359
 360 mapRn f []     = returnRn []
 361 mapRn f (x:xs)
 362   = f x         `thenRn` \ r ->
 363     mapRn f xs  `thenRn` \ rs ->
 364     returnRn (r:rs)
 365
 366 foldlRn k z [] = returnRn z
 367 foldlRn k z (x:xs) = k z x      `thenRn` \ z' ->
 368                      foldlRn k z' xs
 369
 370 mapAndUnzipRn f [] = returnRn ([],[])
 371 mapAndUnzipRn f (x:xs)
 372   = f x                 `thenRn` \ (r1,  r2)  ->
 373     mapAndUnzipRn f xs  `thenRn` \ (rs1, rs2) ->
 374     returnRn (r1:rs1, r2:rs2)
 375
 376 mapAndUnzip3Rn f [] = returnRn ([],[],[])
 377 mapAndUnzip3Rn f (x:xs)
 378   = f x                 `thenRn` \ (r1,  r2,  r3)  ->
 379     mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) ->
 380     returnRn (r1:rs1, r2:rs2, r3:rs3)
 381 \end{code}
 382
 383
 384
 385 %************************************************************************
 386 %*                                                                      *
 387 \subsection{Boring plumbing for common part}
 388 %*                                                                      *
 389 %************************************************************************
 390
 391
 392 ================  Errors and warnings =====================
 393
 394 \begin{code}
 395 failWithRn :: a -> Error -> RnM s d a
 396 failWithRn res msg (RnDown loc names_var errs_var occs_var) l_down
 397   = readMutVarSST  errs_var                                     `thenSST`  \ (warns,errs) ->
 398     writeMutVarSST errs_var (warns, errs `snocBag` err)         `thenSST_`
 399     returnSST res
 400   where
 401     err = addShortErrLocLine loc msg
 402
 403 warnWithRn :: a -> Warning -> RnM s d a
 404 warnWithRn res msg (RnDown loc names_var errs_var occs_var) l_down
 405   = readMutVarSST  errs_var                                     `thenSST`  \ (warns,errs) ->
 406     writeMutVarSST errs_var (warns `snocBag` warn, errs)        `thenSST_`
 407     returnSST res
 408   where
 409     warn = addShortWarnLocLine loc msg
 410
 411 addErrRn :: Error -> RnM s d ()
 412 addErrRn err = failWithRn () err
 413
 414 checkRn :: Bool -> Error -> RnM s d ()  -- Check that a condition is true
 415 checkRn False err  = addErrRn err
 416 checkRn True err = returnRn ()
 417
 418 addWarnRn :: Warning -> RnM s d ()
 419 addWarnRn warn = warnWithRn () warn
 420
 421 checkErrsRn :: RnM s d Bool             -- True <=> no errors so far
 422 checkErrsRn  (RnDown loc names_var errs_var occs_var) l_down
 423   = readMutVarSST  errs_var                                     `thenSST`  \ (warns,errs) ->
 424     returnSST (isEmptyBag errs)
 425 \end{code}
 426
 427
 428 ================  Source location =====================
 429
 430 \begin{code}
 431 pushSrcLocRn :: SrcLoc -> RnM s d a -> RnM s d a
 432 pushSrcLocRn loc' m (RnDown loc names_var errs_var occs_var) l_down
 433   = m (RnDown loc' names_var errs_var occs_var) l_down
 434
 435 getSrcLocRn :: RnM s d SrcLoc
 436 getSrcLocRn (RnDown loc names_var errs_var occs_var) l_down
 437   = returnSST loc
 438 \end{code}
 439
 440 ================  Name supply =====================
 441
 442 \begin{code}
 443 getNameSupplyRn :: RnM s d RnNameSupply
 444 getNameSupplyRn (RnDown loc names_var errs_var occs_var) l_down
 445   = readMutVarSST names_var
 446
 447 setNameSupplyRn :: RnNameSupply -> RnM s d ()
 448 setNameSupplyRn names' (RnDown loc names_var errs_var occs_var) l_down
 449   = writeMutVarSST names_var names'
 450
 451 -- The "instance-decl unique supply", inst, is just an integer that's used to
 452 -- give a unique number for each instance declaration.
 453 newInstUniq :: RnM s d Int
 454 newInstUniq (RnDown loc names_var errs_var occs_var) l_down
 455   = readMutVarSST names_var                             `thenSST` \ (us, inst, cache) ->
 456     writeMutVarSST names_var (us, inst+1, cache)        `thenSST_`
 457     returnSST inst
 458 \end{code}
 459
 460 ================  Occurrences =====================
 461
 462 \begin{code}
 463 addOccurrenceName :: Necessity -> Name -> RnM s d Name  -- Same name returned as passed
 464 addOccurrenceName necessity name (RnDown loc names_var errs_var occs_var) l_down
 465   | isLocallyDefinedName name ||
 466     not_necessary necessity
 467   = returnSST name
 468
 469   | otherwise
 470   = readMutVarSST occs_var                      `thenSST` \ occs ->
 471     writeMutVarSST occs_var ((name,necessity) : occs)   `thenSST_`
 472     returnSST name
 473   where
 474     not_necessary Compulsory = False
 475     not_necessary Optional = opt_IgnoreIfacePragmas
 476                 -- Never look for optional things if we're
 477                 -- ignoring optional input interface information
 478
 479 addOccurrenceNames :: Necessity -> [Name] -> RnM s d ()
 480 addOccurrenceNames necessity names (RnDown loc names_var errs_var occs_var) l_down
 481   = readMutVarSST occs_var                      `thenSST` \ occs ->
 482     writeMutVarSST occs_var ([(name,necessity) | name <- names, not (isLocallyDefinedName name)] ++ occs)
 483
 484 popOccurrenceName :: RnM s d (Maybe (Name,Necessity))
 485 popOccurrenceName (RnDown loc names_var errs_var occs_var) l_down
 486   = readMutVarSST occs_var                      `thenSST` \ occs ->
 487     case occs of
 488         []         -> returnSST Nothing
 489         (occ:occs) -> writeMutVarSST occs_var occs      `thenSST_`
 490                       returnSST (Just occ)
 491
 492 -- findOccurrencesRn does the enclosed thing with a *fresh* occurrences
 493 -- variable, and returns the list of occurrences thus found.  It's useful
 494 -- when loading instance decls and specialisation signatures, when we want to
 495 -- know the names of the things in the types, but we don't want to treat them
 496 -- as occurrences.
 497
 498 findOccurrencesRn :: RnM s d a -> RnM s d [Name]
 499 findOccurrencesRn enclosed_thing (RnDown loc names_var errs_var occs_var) l_down
 500   = newMutVarSST []                                                     `thenSST` \ new_occs_var ->
 501     enclosed_thing (RnDown loc names_var errs_var new_occs_var) l_down  `thenSST_`
 502     readMutVarSST new_occs_var                                          `thenSST` \ occs ->
 503     returnSST (map fst occs)
 504 \end{code}
 505
 506
 507 %************************************************************************
 508 %*                                                                      *
 509 \subsection{Plumbing for rename-source part}
 510 %*                                                                      *
 511 %************************************************************************
 512
 513 ================  RnEnv  =====================
 514
 515 \begin{code}
 516 getGlobalNameEnv :: RnMS s NameEnv
 517 getGlobalNameEnv rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode)
 518   = returnSST global_env
 519
 520 getNameEnv :: RnMS s NameEnv
 521 getNameEnv rn_down (SDown rn_env local_env mod_name mode)
 522   = returnSST local_env
 523
 524 setNameEnv :: NameEnv -> RnMS s a -> RnMS s a
 525 setNameEnv local_env' m rn_down (SDown rn_env local_env mod_name mode)
 526   = m rn_down (SDown rn_env local_env' mod_name mode)
 527
 528 getFixityEnv :: RnMS s FixityEnv
 529 getFixityEnv rn_down (SDown (RnEnv name_env fixity_env) local_env mod_name mode)
 530   = returnSST fixity_env
 531 \end{code}
 532
 533 ================  Module and Mode =====================
 534
 535 \begin{code}
 536 getModuleRn :: RnMS s Module
 537 getModuleRn rn_down (SDown rn_env local_env mod_name mode)
 538   = returnSST mod_name
 539 \end{code}
 540
 541 \begin{code}
 542 getModeRn :: RnMS s RnSMode
 543 getModeRn rn_down (SDown rn_env local_env mod_name mode)
 544   = returnSST mode
 545 \end{code}
 546
 547
 548 %************************************************************************
 549 %*                                                                      *
 550 \subsection{Plumbing for rename-globals part}
 551 %*                                                                      *
 552 %************************************************************************
 553
 554 \begin{code}
 555 getIfacesRn :: RnMG Ifaces
 556 getIfacesRn rn_down (GDown dirs iface_var)
 557   = readMutVarSST iface_var
 558
 559 setIfacesRn :: Ifaces -> RnMG ()
 560 setIfacesRn ifaces rn_down (GDown dirs iface_var)
 561   = writeMutVarSST iface_var ifaces
 562
 563 getSearchPathRn :: RnMG SearchPath
 564 getSearchPathRn rn_down (GDown dirs iface_var)
 565   = returnSST dirs
 566 \end{code}