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