ghc/compiler/rename/RnIfaces.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[RnIfaces]{Cacheing and Renaming of Interfaces}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module RnIfaces (
  10         getInterfaceExports,
  11         getImportedInstDecls,
  12         getSpecialInstModules, getDeferredDataDecls,
  13         importDecl, recordSlurp,
  14         getImportVersions, getSlurpedNames, getRnStats,
  15
  16         checkUpToDate,
  17
  18         getDeclBinders,
  19         mkSearchPath
  20     ) where
  21
  22 IMP_Ubiq()
  23 #if __GLASGOW_HASKELL__ >= 202
  24 import GlaExts (trace) -- TEMP
  25 import IO
  26 #endif
  27
  28
  29 import CmdLineOpts      ( opt_PruneTyDecls,  opt_PruneInstDecls,
  30                           opt_PprUserLength, opt_IgnoreIfacePragmas
  31                         )
  32 import HsSyn            ( HsDecl(..), TyDecl(..), ClassDecl(..), HsTyVar, HsExpr, Sig(..), HsType(..),
  33                           HsBinds(..), MonoBinds, DefaultDecl, ConDecl(..), ConDetails(..), BangType, IfaceSig(..),
  34                           FixityDecl(..), Fixity, Fake, InPat, InstDecl(..), HsIdInfo,
  35                           IE(..), hsDeclName
  36                         )
  37 import HsPragmas        ( noGenPragmas )
  38 import BasicTypes       ( SYN_IE(Version), NewOrData(..) )
  39 import RdrHsSyn         ( SYN_IE(RdrNameHsDecl), SYN_IE(RdrNameInstDecl), SYN_IE(RdrNameTyDecl),
  40                           RdrName, rdrNameOcc
  41                         )
  42 import RnEnv            ( newGlobalName, addImplicitOccsRn,
  43                           availName, availNames, addAvailToNameSet, pprAvail
  44                         )
  45 import RnSource         ( rnHsSigType )
  46 import RnMonad
  47 import RnHsSyn          ( SYN_IE(RenamedHsDecl) )
  48 import ParseIface       ( parseIface )
  49
  50 import ErrUtils         ( SYN_IE(Error), SYN_IE(Warning) )
  51 import FiniteMap        ( FiniteMap, sizeFM, emptyFM, unitFM,  delFromFM,
  52                           lookupFM, addToFM, addToFM_C, addListToFM,
  53                           fmToList, eltsFM
  54                         )
  55 import Name             ( Name {-instance NamedThing-}, Provenance, OccName(..),
  56                           nameModule, occNameString, moduleString, pprModule, isLocallyDefined,
  57                           NameSet(..), emptyNameSet, unionNameSets, nameSetToList,
  58                           minusNameSet, mkNameSet, elemNameSet, nameUnique, addOneToNameSet,
  59                           isWiredInName, maybeWiredInTyConName, maybeWiredInIdName,
  60                           NamedThing(..)
  61                          )
  62 import Id               ( GenId, Id(..), idType, dataConTyCon, isAlgCon )
  63 import TyCon            ( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn )
  64 import Type             ( namesOfType )
  65 import TyVar            ( GenTyVar )
  66 import SrcLoc           ( mkIfaceSrcLoc, SrcLoc )
  67 import PrelMods         ( gHC__ )
  68 import PrelInfo         ( cCallishTyKeys )
  69 import Bag
  70 import Maybes           ( MaybeErr(..), expectJust, maybeToBool )
  71 import ListSetOps       ( unionLists )
  72 import Pretty
  73 import Outputable       ( PprStyle(..) )
  74 import Unique           ( Unique )
  75 import Util             ( pprPanic, pprTrace, Ord3(..) )
  76 import StringBuffer     ( StringBuffer, hGetStringBuffer, freeStringBuffer )
  77 import Outputable
  78 #if __GLASGOW_HASKELL__ >= 202
  79 import List (nub)
  80 #endif
  81 \end{code}
  82
  83
  84
  85 %*********************************************************
  86 %*                                                      *
  87 \subsection{Statistics}
  88 %*                                                      *
  89 %*********************************************************
  90
  91 \begin{code}
  92 getRnStats :: [RenamedHsDecl] -> RnMG Doc
  93 getRnStats all_decls
  94   = getIfacesRn                 `thenRn` \ ifaces ->
  95     let
  96         Ifaces this_mod mod_vers_map export_envs decls_fm all_names imp_names (unslurped_insts,_) deferred_data_decls inst_mods = ifaces
  97         n_mods      = sizeFM mod_vers_map
  98
  99         decls_imported = filter is_imported_decl all_decls
 100         decls_read     = [decl | (name, (_, avail, decl)) <- fmToList decls_fm,
 101                                  name == availName avail,
 102                                         -- Data, newtype, and class decls are in the decls_fm
 103                                         -- under multiple names; the tycon/class, and each
 104                                         -- constructor/class op too.
 105                                  not (isLocallyDefined name)
 106                              ]
 107
 108         (cd_rd, dd_rd, add_rd, nd_rd, and_rd, sd_rd, vd_rd,     _) = count_decls decls_read
 109         (cd_sp, dd_sp, add_sp, nd_sp, and_sp, sd_sp, vd_sp, id_sp) = count_decls decls_imported
 110
 111         inst_decls_unslurped  = length (bagToList unslurped_insts)
 112         inst_decls_read       = id_sp + inst_decls_unslurped
 113
 114         stats = vcat
 115                 [int n_mods <> text " interfaces read",
 116                  hsep [int cd_sp, text "class decls imported, out of",
 117                         int cd_rd, text "read"],
 118                  hsep [int dd_sp, text "data decls imported (of which", int add_sp, text "abstractly), out of",
 119                         int dd_rd, text "read"],
 120                  hsep [int nd_sp, text "newtype decls imported (of which", int and_sp, text "abstractly), out of",
 121                         int nd_rd, text "read"],
 122                  hsep [int sd_sp, text "type synonym decls imported, out of",
 123                         int sd_rd, text "read"],
 124                  hsep [int vd_sp, text "value signatures imported, out of",
 125                         int vd_rd, text "read"],
 126                  hsep [int id_sp, text "instance decls imported, out of",
 127                         int inst_decls_read, text "read"]
 128                 ]
 129     in
 130     returnRn (hcat [text "Renamer stats: ", stats])
 131
 132 is_imported_decl (DefD _) = False
 133 is_imported_decl (ValD _) = False
 134 is_imported_decl decl     = not (isLocallyDefined (hsDeclName decl))
 135
 136 count_decls decls
 137   = -- pprTrace "count_decls" (ppr PprDebug  decls
 138     --
 139     --                      $$
 140     --                      text "========="
 141     --                      $$
 142     --                      ppr PprDebug imported_decls
 143     --  ) $
 144     (class_decls,
 145      data_decls,    abstract_data_decls,
 146      newtype_decls, abstract_newtype_decls,
 147      syn_decls,
 148      val_decls,
 149      inst_decls)
 150   where
 151     class_decls   = length [() | ClD _                      <- decls]
 152     data_decls    = length [() | TyD (TyData DataType _ _ _ _ _ _ _) <- decls]
 153     newtype_decls = length [() | TyD (TyData NewType  _ _ _ _ _ _ _) <- decls]
 154     abstract_data_decls    = length [() | TyD (TyData DataType _ _ _ [] _ _ _) <- decls]
 155     abstract_newtype_decls = length [() | TyD (TyData NewType  _ _ _ [] _ _ _) <- decls]
 156     syn_decls     = length [() | TyD (TySynonym _ _ _ _)    <- decls]
 157     val_decls     = length [() | SigD _                     <- decls]
 158     inst_decls    = length [() | InstD _                    <- decls]
 159
 160 \end{code}
 161
 162 %*********************************************************
 163 %*                                                      *
 164 \subsection{Loading a new interface file}
 165 %*                                                      *
 166 %*********************************************************
 167
 168 \begin{code}
 169 loadInterface :: Doc -> Module -> Bool -> RnMG Ifaces
 170 loadInterface doc_str load_mod as_source
 171   = getIfacesRn                 `thenRn` \ ifaces ->
 172     let
 173         Ifaces this_mod mod_vers_map export_envs decls
 174                all_names imp_names (insts, tycls_names)
 175                deferred_data_decls inst_mods = ifaces
 176     in
 177         -- CHECK WHETHER WE HAVE IT ALREADY
 178     if maybeToBool (lookupFM export_envs load_mod)
 179     then
 180         returnRn ifaces         -- Already in the cache; don't re-read it
 181     else
 182
 183         -- READ THE MODULE IN
 184     findAndReadIface doc_str load_mod           `thenRn` \ read_result ->
 185     case read_result of {
 186         -- Check for not found
 187         Nothing ->      -- Not found, so add an empty export env to the Ifaces map
 188                         -- so that we don't look again
 189                    let
 190                         new_export_envs = addToFM export_envs load_mod ([],[])
 191                         new_ifaces = Ifaces this_mod mod_vers_map
 192                                             new_export_envs
 193                                             decls all_names imp_names (insts, tycls_names) deferred_data_decls inst_mods
 194                    in
 195                    setIfacesRn new_ifaces               `thenRn_`
 196                    failWithRn new_ifaces (noIfaceErr load_mod) ;
 197
 198         -- Found and parsed!
 199         Just (ParsedIface _ mod_vers usages exports rd_inst_mods fixs rd_decls rd_insts) ->
 200
 201         -- LOAD IT INTO Ifaces
 202     mapRn loadExport exports                             `thenRn` \ avails_s ->
 203     foldlRn (loadDecl load_mod as_source) decls rd_decls `thenRn` \ new_decls ->
 204     foldlRn (loadInstDecl load_mod) insts rd_insts       `thenRn` \ new_insts ->
 205     let
 206          export_env = (concat avails_s, fixs)
 207
 208                         -- Exclude this module from the "special-inst" modules
 209          new_inst_mods = inst_mods `unionLists` (filter (/= this_mod) rd_inst_mods)
 210
 211          new_ifaces = Ifaces this_mod
 212                              (addToFM mod_vers_map load_mod mod_vers)
 213                              (addToFM export_envs load_mod export_env)
 214                              new_decls
 215                              all_names imp_names
 216                              (new_insts, tycls_names)
 217                              deferred_data_decls
 218                              new_inst_mods
 219     in
 220     setIfacesRn new_ifaces              `thenRn_`
 221     returnRn new_ifaces
 222     }
 223
 224 loadExport :: ExportItem -> RnMG [AvailInfo]
 225 loadExport (mod, entities)
 226   = mapRn load_entity entities
 227   where
 228     new_name occ = newGlobalName mod occ
 229
 230 -- The communcation between this little code fragment and the "entity" rule
 231 -- in ParseIface.y is a bit gruesome.  The idea is that things which are
 232 -- destined to be AvailTCs show up as (occ, [non-empty-list]), whereas
 233 -- things destined to be Avails show up as (occ, [])
 234
 235     load_entity (occ, occs)
 236       = new_name occ            `thenRn` \ name ->
 237         if null occs then
 238                 returnRn (Avail name)
 239         else
 240                 mapRn new_name occs     `thenRn` \ names ->
 241                 returnRn (AvailTC name names)
 242
 243 loadDecl :: Module
 244          -> Bool
 245          -> DeclsMap
 246          -> (Version, RdrNameHsDecl)
 247          -> RnMG DeclsMap
 248 loadDecl mod as_source decls_map (version, decl)
 249   = getDeclBinders new_implicit_name decl       `thenRn` \ avail ->
 250     returnRn (addListToFM decls_map
 251                           [(name,(version,avail,decl')) | name <- availNames avail]
 252     )
 253   where
 254     {-
 255       If a signature decl is being loaded and we're ignoring interface pragmas,
 256       toss away unfolding information.
 257
 258       Also, if the signature is loaded from a module we're importing from source,
 259       we do the same. This is to avoid situations when compiling a pair of mutually
 260       recursive modules, peering at unfolding info in the interface file of the other,
 261       e.g., you compile A, it looks at B's interface file and may as a result change
 262       it's interface file. Hence, B is recompiled, maybe changing it's interface file,
 263       which will the ufolding info used in A to become invalid. Simple way out is to
 264       just ignore unfolding info.
 265     -}
 266     decl' =
 267      case decl of
 268        SigD (IfaceSig name tp ls loc) | as_source || opt_IgnoreIfacePragmas ->
 269             SigD (IfaceSig name tp [] loc)
 270        _ -> decl
 271
 272     new_implicit_name rdr_name loc = newGlobalName mod (rdrNameOcc rdr_name)
 273
 274 loadInstDecl :: Module
 275              -> Bag IfaceInst
 276              -> RdrNameInstDecl
 277              -> RnMG (Bag IfaceInst)
 278 loadInstDecl mod_name insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc)
 279   =
 280         -- Find out what type constructors and classes are "gates" for the
 281         -- instance declaration.  If all these "gates" are slurped in then
 282         -- we should slurp the instance decl too.
 283         --
 284         -- We *don't* want to count names in the context part as gates, though.
 285         -- For example:
 286         --              instance Foo a => Baz (T a) where ...
 287         --
 288         -- Here the gates are Baz and T, but *not* Foo.
 289     let
 290         munged_inst_ty = case inst_ty of
 291                                 HsForAllTy tvs cxt ty -> HsForAllTy tvs [] ty
 292                                 HsPreForAllTy cxt ty  -> HsPreForAllTy [] ty
 293                                 other                 -> inst_ty
 294     in
 295         -- We find the gates by renaming the instance type with in a
 296         -- and returning the occurrence pool.
 297     initRnMS emptyRnEnv mod_name (InterfaceMode Compulsory) (
 298         findOccurrencesRn (rnHsSigType (\sty -> text "an instance decl") munged_inst_ty)
 299     )                                           `thenRn` \ gate_names ->
 300     returnRn (((mod_name, decl), gate_names) `consBag` insts)
 301 \end{code}
 302
 303
 304 %********************************************************
 305 %*                                                      *
 306 \subsection{Loading usage information}
 307 %*                                                      *
 308 %********************************************************
 309
 310 \begin{code}
 311 checkUpToDate :: Module -> RnMG Bool            -- True <=> no need to recompile
 312 checkUpToDate mod_name
 313   = findAndReadIface doc_str mod_name           `thenRn` \ read_result ->
 314     case read_result of
 315         Nothing ->      -- Old interface file not found, so we'd better bail out
 316                     traceRn (sep [ptext SLIT("Didnt find old iface"),
 317                                     pprModule PprDebug mod_name])       `thenRn_`
 318                     returnRn False
 319
 320         Just (ParsedIface _ _ usages _ _ _ _ _)
 321                 ->      -- Found it, so now check it
 322                     checkModUsage usages
 323   where
 324         -- Only look in current directory, with suffix .hi
 325     doc_str = sep [ptext SLIT("Need usage info from"), pprModule PprDebug mod_name]
 326
 327 checkModUsage [] = returnRn True                -- Yes!  Everything is up to date!
 328
 329 checkModUsage ((mod, old_mod_vers, old_local_vers) : rest)
 330   = loadInterface doc_str mod False{-not as source-} `thenRn` \ ifaces ->
 331     let
 332         Ifaces _ mod_vers _ decls _ _ _ _ _ = ifaces
 333         maybe_new_mod_vers = lookupFM mod_vers mod
 334         Just new_mod_vers  = maybe_new_mod_vers
 335     in
 336         -- If we can't find a version number for the old module then
 337         -- bail out saying things aren't up to date
 338     if not (maybeToBool maybe_new_mod_vers) then
 339         returnRn False
 340     else
 341
 342         -- If the module version hasn't changed, just move on
 343     if new_mod_vers == old_mod_vers then
 344         traceRn (sep [ptext SLIT("Module version unchanged:"), pprModule PprDebug mod]) `thenRn_`
 345         checkModUsage rest
 346     else
 347     traceRn (sep [ptext SLIT("Module version has changed:"), pprModule PprDebug mod])   `thenRn_`
 348
 349         -- New module version, so check entities inside
 350     checkEntityUsage mod decls old_local_vers   `thenRn` \ up_to_date ->
 351     if up_to_date then
 352         traceRn (ptext SLIT("...but the bits I use haven't."))  `thenRn_`
 353         checkModUsage rest      -- This one's ok, so check the rest
 354     else
 355         returnRn False          -- This one failed, so just bail out now
 356   where
 357     doc_str = sep [ptext SLIT("need version info for"), pprModule PprDebug mod]
 358
 359
 360 checkEntityUsage mod decls []
 361   = returnRn True       -- Yes!  All up to date!
 362
 363 checkEntityUsage mod decls ((occ_name,old_vers) : rest)
 364   = newGlobalName mod occ_name          `thenRn` \ name ->
 365     case lookupFM decls name of
 366
 367         Nothing       ->        -- We used it before, but it ain't there now
 368                           traceRn (sep [ptext SLIT("...and this no longer exported:"), ppr PprDebug name])      `thenRn_`
 369                           returnRn False
 370
 371         Just (new_vers,_,_)     -- It's there, but is it up to date?
 372                 | new_vers == old_vers
 373                         -- Up to date, so check the rest
 374                 -> checkEntityUsage mod decls rest
 375
 376                 | otherwise
 377                         -- Out of date, so bale out
 378                 -> traceRn (sep [ptext SLIT("...and this is out of date:"), ppr PprDebug name])  `thenRn_`
 379                    returnRn False
 380 \end{code}
 381
 382
 383 %*********************************************************
 384 %*                                                      *
 385 \subsection{Getting in a declaration}
 386 %*                                                      *
 387 %*********************************************************
 388
 389 \begin{code}
 390 importDecl :: Name -> Necessity -> RnMG (Maybe RdrNameHsDecl)
 391         -- Returns Nothing for a wired-in or already-slurped decl
 392
 393 importDecl name necessity
 394   = checkSlurped name                   `thenRn` \ already_slurped ->
 395     if already_slurped then
 396         traceRn (sep [text "Already slurped:", ppr PprDebug name])      `thenRn_`
 397         returnRn Nothing        -- Already dealt with
 398     else
 399     if isWiredInName name then
 400         getWiredInDecl name necessity
 401     else
 402        getIfacesRn              `thenRn` \ ifaces ->
 403        let
 404          Ifaces this_mod _ _ _ _ _ _ _ _ = ifaces
 405          mod = nameModule name
 406        in
 407        if mod == this_mod  then    -- Don't bring in decls from
 408           pprTrace "importDecl wierdness:" (ppr PprDebug name) $
 409           returnRn Nothing         -- the renamed module's own interface file
 410                                    --
 411        else
 412         getNonWiredInDecl name necessity
 413 \end{code}
 414
 415 \begin{code}
 416 getNonWiredInDecl :: Name -> Necessity -> RnMG (Maybe RdrNameHsDecl)
 417 getNonWiredInDecl needed_name necessity
 418   = traceRn doc_str                                     `thenRn_`
 419     loadInterface doc_str mod False{-not as source -}   `thenRn` \ (Ifaces _ _ _ decls _ _ _ _ _) ->
 420     case lookupFM decls needed_name of
 421
 422         -- Special case for data/newtype type declarations
 423       Just (version, avail, TyD ty_decl) | is_data_or_newtype ty_decl
 424               -> getNonWiredDataDecl needed_name version avail ty_decl  `thenRn` \ (avail', maybe_decl) ->
 425                  recordSlurp (Just version) necessity avail'    `thenRn_`
 426                  returnRn maybe_decl
 427
 428       Just (version,avail,decl)
 429               -> recordSlurp (Just version) necessity avail     `thenRn_`
 430                  returnRn (Just decl)
 431
 432       Nothing ->        -- Can happen legitimately for "Optional" occurrences
 433                    case necessity of {
 434                                 Optional -> addWarnRn (getDeclWarn needed_name);
 435                                 other    -> addErrRn  (getDeclErr  needed_name)
 436                    }                                            `thenRn_`
 437                    returnRn Nothing
 438   where
 439      doc_str = sep [ptext SLIT("Need decl for"), ppr PprDebug needed_name]
 440      mod = nameModule needed_name
 441
 442      is_data_or_newtype (TyData _ _ _ _ _ _ _ _) = True
 443      is_data_or_newtype other                    = False
 444 \end{code}
 445
 446 @getWiredInDecl@ maps a wired-in @Name@ to what it makes available.
 447 It behaves exactly as if the wired in decl were actually in an interface file.
 448 Specifically,
 449
 450   *     if the wired-in name is a data type constructor or a data constructor,
 451         it brings in the type constructor and all the data constructors; and
 452         marks as "occurrences" any free vars of the data con.
 453
 454   *     similarly for synonum type constructor
 455
 456   *     if the wired-in name is another wired-in Id, it marks as "occurrences"
 457         the free vars of the Id's type.
 458
 459   *     it loads the interface file for the wired-in thing for the
 460         sole purpose of making sure that its instance declarations are available
 461
 462 All this is necessary so that we know all types that are "in play", so
 463 that we know just what instances to bring into scope.
 464
 465 \begin{code}
 466 getWiredInDecl name necessity
 467   = initRnMS emptyRnEnv mod_name (InterfaceMode necessity)
 468              get_wired                          `thenRn` \ avail ->
 469     recordSlurp Nothing necessity avail         `thenRn_`
 470
 471         -- Force in the home module in case it has instance decls for
 472         -- the thing we are interested in.
 473         --
 474         -- Mini hack 1: no point for non-tycons/class; and if we
 475         -- do this we find PrelNum trying to import PackedString,
 476         -- because PrelBase's .hi file mentions PackedString.unpackString
 477         -- But PackedString.hi isn't built by that point!
 478         --
 479         -- Mini hack 2; GHC is guaranteed not to have
 480         -- instance decls, so it's a waste of time to read it
 481         --
 482         -- NB: We *must* look at the availName of the slurped avail,
 483         -- not the name passed to getWiredInDecl!  Why?  Because if a data constructor
 484         -- or class op is passed to getWiredInDecl we'll pull in the whole data/class
 485         -- decl, and recordSlurp will record that fact.  But since the data constructor
 486         -- isn't a tycon/class we won't force in the home module.  And even if the
 487         -- type constructor/class comes along later, loadDecl will say that it's already
 488         -- been slurped, so getWiredInDecl won't even be called.  Pretty obscure bug, this was.
 489     let
 490         main_name  = availName avail
 491         main_is_tc = case avail of { AvailTC _ _ -> True; Avail _ -> False }
 492         mod        = nameModule main_name
 493         doc_str    = sep [ptext SLIT("Need home module for wired in thing"), ppr PprDebug name]
 494     in
 495     (if not main_is_tc || mod == gHC__ then
 496         returnRn ()
 497     else
 498         loadInterface doc_str mod False{-not as source-}        `thenRn_`
 499         returnRn ()
 500     )                                                           `thenRn_`
 501
 502     returnRn Nothing            -- No declaration to process further
 503   where
 504
 505     get_wired | is_tycon                        -- ... a type constructor
 506               = get_wired_tycon the_tycon
 507
 508               | (isAlgCon the_id)               -- ... a wired-in data constructor
 509               = get_wired_tycon (dataConTyCon the_id)
 510
 511               | otherwise                       -- ... a wired-in non data-constructor
 512               = get_wired_id the_id
 513
 514     mod_name             = nameModule name
 515     maybe_wired_in_tycon = maybeWiredInTyConName name
 516     is_tycon             = maybeToBool maybe_wired_in_tycon
 517     maybe_wired_in_id    = maybeWiredInIdName    name
 518     Just the_tycon       = maybe_wired_in_tycon
 519     Just the_id          = maybe_wired_in_id
 520
 521
 522 get_wired_id id
 523   = addImplicitOccsRn (nameSetToList id_mentioned)      `thenRn_`
 524     returnRn (Avail (getName id))
 525   where
 526     id_mentioned = namesOfType (idType id)
 527
 528 get_wired_tycon tycon
 529   | isSynTyCon tycon
 530   = addImplicitOccsRn (nameSetToList mentioned)         `thenRn_`
 531     returnRn (AvailTC tc_name [tc_name])
 532   where
 533     tc_name     = getName tycon
 534     (tyvars,ty) = getSynTyConDefn tycon
 535     mentioned   = namesOfType ty `minusNameSet` mkNameSet (map getName tyvars)
 536
 537 get_wired_tycon tycon
 538   | otherwise           -- data or newtype
 539   = addImplicitOccsRn (nameSetToList mentioned)         `thenRn_`
 540     returnRn (AvailTC tycon_name (tycon_name : map getName data_cons))
 541   where
 542     tycon_name = getName tycon
 543     data_cons  = tyConDataCons tycon
 544     mentioned  = foldr (unionNameSets . namesOfType . idType) emptyNameSet data_cons
 545 \end{code}
 546
 547
 548
 549 %*********************************************************
 550 %*                                                      *
 551 \subsection{Getting what a module exports}
 552 %*                                                      *
 553 %*********************************************************
 554
 555 \begin{code}
 556 getInterfaceExports :: Module -> Bool -> RnMG (Avails, [(OccName,Fixity)])
 557 getInterfaceExports mod as_source
 558   = loadInterface doc_str mod as_source `thenRn` \ (Ifaces _ _ export_envs _ _ _ _ _ _) ->
 559     case lookupFM export_envs mod of
 560         Nothing ->      -- Not there; it must be that the interface file wasn't found;
 561                         -- the error will have been reported already.
 562                         -- (Actually loadInterface should put the empty export env in there
 563                         --  anyway, but this does no harm.)
 564                       returnRn ([],[])
 565
 566         Just stuff -> returnRn stuff
 567   where
 568     doc_str = sep [pprModule PprDebug mod, ptext SLIT("is directly imported")]
 569 \end{code}
 570
 571
 572 %*********************************************************
 573 %*                                                      *
 574 \subsection{Data type declarations are handled specially}
 575 %*                                                      *
 576 %*********************************************************
 577
 578 Data type declarations get special treatment.  If we import a data type decl
 579 with all its constructors, we end up importing all the types mentioned in
 580 the constructors' signatures, and hence {\em their} data type decls, and so on.
 581 In effect, we get the transitive closure of data type decls.  Worse, this drags
 582 in tons on instance decls, and their unfoldings, and so on.
 583
 584 If only the type constructor is mentioned, then all this is a waste of time.
 585 If any of the data constructors are mentioned then we really have to
 586 drag in the whole declaration.
 587
 588 So when we import the type constructor for a @data@ or @newtype@ decl, we
 589 put it in the "deferred data/newtype decl" pile in Ifaces.  Right at the end
 590 we slurp these decls, if they havn't already been dragged in by an occurrence
 591 of a constructor.
 592
 593 \begin{code}
 594 getNonWiredDataDecl needed_name
 595                     version
 596                     avail@(AvailTC tycon_name _)
 597                     ty_decl@(TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)
 598   |  needed_name == tycon_name
 599   && opt_PruneTyDecls
 600   && not (nameUnique needed_name `elem` cCallishTyKeys)         -- Hack!  Don't prune these tycons whose constructors
 601                                                                 -- the desugarer must be able to see when desugaring
 602                                                                 -- a CCall.  Ugh!
 603   =     -- Need the type constructor; so put it in the deferred set for now
 604     getIfacesRn                 `thenRn` \ ifaces ->
 605     let
 606         Ifaces this_mod mod_vers_map export_envs decls_fm slurped_names imp_names unslurped_insts deferred_data_decls inst_mods = ifaces
 607         new_ifaces = Ifaces this_mod mod_vers_map export_envs decls_fm slurped_names imp_names unslurped_insts new_deferred_data_decls inst_mods
 608
 609         no_constr_ty_decl       = TyData new_or_data [] tycon tyvars [] derivings pragmas src_loc
 610         new_deferred_data_decls = addToFM deferred_data_decls tycon_name no_constr_ty_decl
 611                 -- Nota bene: we nuke both the constructors and the context in the deferred decl.
 612                 -- If we don't nuke the context then renaming the deferred data decls can give
 613                 -- new unresolved names (for the classes).  This could be handled, but there's
 614                 -- no point.  If the data type is completely abstract then we aren't interested
 615                 -- its context.
 616     in
 617     setIfacesRn new_ifaces      `thenRn_`
 618     returnRn (AvailTC tycon_name [tycon_name], Nothing)
 619
 620   | otherwise
 621   =     -- Need a data constructor, so delete the data decl from the deferred set if it's there
 622     getIfacesRn                 `thenRn` \ ifaces ->
 623     let
 624         Ifaces this_mod mod_vers_map export_envs decls_fm slurped_names imp_names unslurped_insts deferred_data_decls inst_mods = ifaces
 625         new_ifaces = Ifaces this_mod mod_vers_map export_envs decls_fm slurped_names imp_names unslurped_insts new_deferred_data_decls inst_mods
 626
 627         new_deferred_data_decls = delFromFM deferred_data_decls tycon_name
 628     in
 629     setIfacesRn new_ifaces      `thenRn_`
 630     returnRn (avail, Just (TyD ty_decl))
 631 \end{code}
 632
 633 \begin{code}
 634 getDeferredDataDecls :: RnMG [(Name, RdrNameTyDecl)]
 635 getDeferredDataDecls
 636   = getIfacesRn                 `thenRn` \ (Ifaces _ _ _ _ _ _ _ deferred_data_decls _) ->
 637     let
 638         deferred_list = fmToList deferred_data_decls
 639         trace_msg = hang (text "Slurping abstract data/newtype decls for: ")
 640                         4 (ppr PprDebug (map fst deferred_list))
 641     in
 642     traceRn trace_msg                   `thenRn_`
 643     returnRn deferred_list
 644 \end{code}
 645
 646
 647 %*********************************************************
 648 %*                                                      *
 649 \subsection{Instance declarations are handled specially}
 650 %*                                                      *
 651 %*********************************************************
 652
 653 \begin{code}
 654 getImportedInstDecls :: RnMG [(Module,RdrNameInstDecl)]
 655 getImportedInstDecls
 656   =     -- First load any special-instance modules that aren't aready loaded
 657     getSpecialInstModules                       `thenRn` \ inst_mods ->
 658     mapRn load_it inst_mods                     `thenRn_`
 659
 660         -- Now we're ready to grab the instance declarations
 661         -- Find the un-gated ones and return them,
 662         -- removing them from the bag kept in Ifaces
 663     getIfacesRn         `thenRn` \ ifaces ->
 664     let
 665         Ifaces this_mod mod_vers export_envs decls slurped_names imp_names (insts, tycls_names) deferred_data_decls inst_mods = ifaces
 666
 667                 -- An instance decl is ungated if all its gates have been slurped
 668         select_ungated :: IfaceInst                                     -- A gated inst decl
 669
 670                        -> ([(Module, RdrNameInstDecl)], [IfaceInst])    -- Accumulator
 671
 672                        -> ([(Module, RdrNameInstDecl)],                 -- The ungated ones
 673                            [IfaceInst])                                 -- Still gated, but with
 674                                                                         -- depeleted gates
 675         select_ungated (decl,gates) (ungated_decls, gated_decls)
 676           | null remaining_gates
 677           = (decl : ungated_decls, gated_decls)
 678           | otherwise
 679           = (ungated_decls, (decl, remaining_gates) : gated_decls)
 680           where
 681             remaining_gates = filter (not . (`elemNameSet` tycls_names)) gates
 682
 683         (un_gated_insts, still_gated_insts) = foldrBag select_ungated ([], []) insts
 684
 685         new_ifaces = Ifaces this_mod mod_vers export_envs decls slurped_names imp_names
 686                             ((listToBag still_gated_insts), tycls_names)
 687                                 -- NB: don't throw away tycls_names; we may comre across more instance decls
 688                             deferred_data_decls
 689                             inst_mods
 690     in
 691     traceRn (sep [text "getInstDecls:", fsep (map (ppr PprDebug) (nameSetToList tycls_names))]) `thenRn_`
 692     setIfacesRn new_ifaces      `thenRn_`
 693     returnRn un_gated_insts
 694   where
 695     load_it mod = loadInterface (doc_str mod) mod False{- not as source-}
 696     doc_str mod = sep [pprModule PprDebug mod, ptext SLIT("is a special-instance module")]
 697
 698
 699 getSpecialInstModules :: RnMG [Module]
 700 getSpecialInstModules
 701   = getIfacesRn                                         `thenRn` \ ifaces ->
 702     let
 703          Ifaces _ _ _ _ _ _ _ _ inst_mods = ifaces
 704     in
 705     returnRn inst_mods
 706 \end{code}
 707
 708
 709 %*********************************************************
 710 %*                                                      *
 711 \subsection{Keeping track of what we've slurped, and version numbers}
 712 %*                                                      *
 713 %*********************************************************
 714
 715 getImportVersions figures out what the "usage information" for this moudule is;
 716 that is, what it must record in its interface file as the things it uses.
 717 It records:
 718         - anything reachable from its body code
 719         - any module exported with a "module Foo".
 720
 721 Why the latter?  Because if Foo changes then this module's export list
 722 will change, so we must recompile this module at least as far as
 723 making a new interface file --- but in practice that means complete
 724 recompilation.
 725
 726 What about this?
 727         module A( f, g ) where          module B( f ) where
 728           import B( f )                   f = h 3
 729           g = ...                         h = ...
 730
 731 Should we record B.f in A's usages?  In fact we don't.  Certainly, if
 732 anything about B.f changes than anyone who imports A should be recompiled;
 733 they'll get an early exit if they don't use B.f.  However, even if B.f
 734 doesn't change at all, B.h may do so, and this change may not be reflected
 735 in f's version number.  So there are two things going on when compiling module A:
 736
 737 1.  Are A.o and A.hi correct?  Then we can bale out early.
 738 2.  Should modules that import A be recompiled?
 739
 740 For (1) it is slightly harmful to record B.f in A's usages, because a change in
 741 B.f's version will provoke full recompilation of A, producing an identical A.o,
 742 and A.hi differing only in its usage-version of B.f (which isn't used by any importer).
 743
 744 For (2), because of the tricky B.h question above, we ensure that A.hi is touched
 745 (even if identical to its previous version) if A's recompilation was triggered by
 746 an imported .hi file date change.  Given that, there's no need to record B.f in
 747 A's usages.
 748
 749 On the other hand, if A exports "module B" then we *do* count module B among
 750 A's usages, because we must recompile A to ensure that A.hi changes appropriately.
 751
 752 \begin{code}
 753 getImportVersions :: Module                     -- Name of this module
 754                   -> Maybe [IE any]             -- Export list for this module
 755                   -> RnMG (VersionInfo Name)    -- Version info for these names
 756
 757 getImportVersions this_mod exports
 758   = getIfacesRn                                 `thenRn` \ ifaces ->
 759     let
 760          Ifaces _ mod_versions_map _ _ _ imp_names _ _ _ = ifaces
 761          mod_version mod = expectJust "import_versions" (lookupFM mod_versions_map mod)
 762
 763          -- mv_map groups together all the things imported from a particular module.
 764          mv_map, mv_map_mod :: FiniteMap Module [LocalVersion Name]
 765
 766          mv_map_mod = foldl add_mod emptyFM export_mods
 767                 -- mv_map_mod records all the modules that have a "module M"
 768                 -- in this module's export list
 769
 770          mv_map = foldl add_mv mv_map_mod imp_names
 771                 -- mv_map adds the version numbers of things exported individually
 772     in
 773     returnRn [ (mod, mod_version mod, local_versions)
 774              | (mod, local_versions) <- fmToList mv_map
 775              ]
 776
 777   where
 778      export_mods = case exports of
 779                         Nothing -> []
 780                         Just es -> [mod | IEModuleContents mod <- es, mod /= this_mod]
 781
 782      add_mv mv_map v@(name, version)
 783       = addToFM_C (\ ls _ -> (v:ls)) mv_map mod [v]
 784         where
 785          mod = nameModule name
 786
 787      add_mod mv_map mod = addToFM mv_map mod []
 788 \end{code}
 789
 790 \begin{code}
 791 checkSlurped name
 792   = getIfacesRn         `thenRn` \ (Ifaces _ _ _ _ slurped_names _ _ _ _) ->
 793     returnRn (name `elemNameSet` slurped_names)
 794
 795 getSlurpedNames :: RnMG NameSet
 796 getSlurpedNames
 797   = getIfacesRn         `thenRn` \ ifaces ->
 798     let
 799          Ifaces _ _ _ _ slurped_names _ _ _ _ = ifaces
 800     in
 801     returnRn slurped_names
 802
 803 recordSlurp maybe_version necessity avail
 804   = traceRn (hsep [text "Record slurp:", pprAvail (PprForUser opt_PprUserLength) avail,
 805                                         -- NB PprForDebug prints export flag, which is too
 806                                         -- strict; it's a knot-tied thing in RnNames
 807                   case necessity of {Compulsory -> text "comp"; Optional -> text "opt"}])       `thenRn_`
 808     getIfacesRn         `thenRn` \ ifaces ->
 809     let
 810         Ifaces this_mod mod_vers export_envs decls slurped_names imp_names (insts, tycls_names) deferred_data_decls inst_mods = ifaces
 811         new_slurped_names = addAvailToNameSet slurped_names avail
 812
 813         new_imp_names = case maybe_version of
 814                            Just version -> (availName avail, version) : imp_names
 815                            Nothing      -> imp_names
 816
 817                 -- Add to the names that will let in instance declarations;
 818                 -- but only (a) if it's a type/class
 819                 --          (b) if it's compulsory (unless the test flag opt_PruneInstDecls is off)
 820         new_tycls_names = case avail of
 821                                 AvailTC tc _  | not opt_PruneInstDecls ||
 822                                                 case necessity of {Optional -> False; Compulsory -> True }
 823                                               -> tycls_names `addOneToNameSet` tc
 824                                 otherwise     -> tycls_names
 825
 826         new_ifaces = Ifaces this_mod mod_vers export_envs decls
 827                             new_slurped_names
 828                             new_imp_names
 829                             (insts, new_tycls_names)
 830                             deferred_data_decls
 831                             inst_mods
 832     in
 833     setIfacesRn new_ifaces
 834 \end{code}
 835
 836
 837 %*********************************************************
 838 %*                                                      *
 839 \subsection{Getting binders out of a declaration}
 840 %*                                                      *
 841 %*********************************************************
 842
 843 @getDeclBinders@ returns the names for a @RdrNameHsDecl@.
 844 It's used for both source code (from @availsFromDecl@) and interface files
 845 (from @loadDecl@).
 846
 847 It doesn't deal with source-code specific things: ValD, DefD.  They
 848 are handled by the sourc-code specific stuff in RnNames.
 849
 850 \begin{code}
 851 getDeclBinders :: (RdrName -> SrcLoc -> RnMG Name)      -- New-name function
 852                 -> RdrNameHsDecl
 853                 -> RnMG AvailInfo
 854
 855 getDeclBinders new_name (TyD (TyData _ _ tycon _ condecls _ _ src_loc))
 856   = new_name tycon src_loc                      `thenRn` \ tycon_name ->
 857     getConFieldNames new_name condecls          `thenRn` \ sub_names ->
 858     returnRn (AvailTC tycon_name (tycon_name : nub sub_names))
 859         -- The "nub" is because getConFieldNames can legitimately return duplicates,
 860         -- when a record declaration has the same field in multiple constructors
 861
 862 getDeclBinders new_name (TyD (TySynonym tycon _ _ src_loc))
 863   = new_name tycon src_loc              `thenRn` \ tycon_name ->
 864     returnRn (AvailTC tycon_name [tycon_name])
 865
 866 getDeclBinders new_name (ClD (ClassDecl _ cname _ sigs _ _ src_loc))
 867   = new_name cname src_loc                      `thenRn` \ class_name ->
 868     mapRn (getClassOpNames new_name) sigs       `thenRn` \ sub_names ->
 869     returnRn (AvailTC class_name (class_name : sub_names))
 870
 871 getDeclBinders new_name (SigD (IfaceSig var ty prags src_loc))
 872   = new_name var src_loc                        `thenRn` \ var_name ->
 873     returnRn (Avail var_name)
 874
 875 getDeclBinders new_name (DefD _)  = returnRn NotAvailable
 876 getDeclBinders new_name (InstD _) = returnRn NotAvailable
 877
 878 ----------------
 879 getConFieldNames new_name (ConDecl con _ (RecCon fielddecls) src_loc : rest)
 880   = mapRn (\n -> new_name n src_loc) (con:fields)       `thenRn` \ cfs ->
 881     getConFieldNames new_name rest                      `thenRn` \ ns  ->
 882     returnRn (cfs ++ ns)
 883   where
 884     fields = concat (map fst fielddecls)
 885
 886 getConFieldNames new_name (ConDecl con _ _ src_loc : rest)
 887   = new_name con src_loc                `thenRn` \ n ->
 888     getConFieldNames new_name rest      `thenRn` \ ns ->
 889     returnRn (n:ns)
 890
 891 getConFieldNames new_name [] = returnRn []
 892
 893 getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc
 894 \end{code}
 895
 896
 897 %*********************************************************
 898 %*                                                      *
 899 \subsection{Reading an interface file}
 900 %*                                                      *
 901 %*********************************************************
 902
 903 \begin{code}
 904 findAndReadIface :: Doc -> Module -> RnMG (Maybe ParsedIface)
 905         -- Nothing <=> file not found, or unreadable, or illegible
 906         -- Just x  <=> successfully found and parsed
 907 findAndReadIface doc_str filename
 908   = traceRn trace_msg                   `thenRn_`
 909     getSearchPathRn                     `thenRn` \ dirs ->
 910     try dirs dirs
 911   where
 912     trace_msg = hang (hcat [ptext SLIT("Reading interface for "),
 913                             ptext filename, semi])
 914                      4 (hcat [ptext SLIT("reason: "), doc_str])
 915
 916     try all_dirs [] = traceRn (ptext SLIT("...failed")) `thenRn_`
 917                       returnRn Nothing
 918
 919     try all_dirs ((dir,hisuf):dirs)
 920         = readIface file_path   `thenRn` \ read_result ->
 921           case read_result of
 922               Nothing    -> try all_dirs dirs
 923               Just iface -> traceRn (ptext SLIT("...done"))     `thenRn_`
 924                             returnRn (Just iface)
 925         where
 926           file_path = dir ++ '/':moduleString filename ++ hisuf
 927 \end{code}
 928
 929 @readIface@ trys just one file.
 930
 931 \begin{code}
 932 readIface :: String -> RnMG (Maybe ParsedIface)
 933         -- Nothing <=> file not found, or unreadable, or illegible
 934         -- Just x  <=> successfully found and parsed
 935 readIface file_path
 936   = ioToRnMG (hGetStringBuffer file_path)                       `thenRn` \ read_result ->
 937     --traceRn (hcat[ptext SLIT("Opening...."), text file_path])   `thenRn_`
 938     case read_result of
 939         Right contents    ->
 940              case parseIface contents of
 941                   Failed err      ->
 942                      --traceRn (ptext SLIT("parse err"))      `thenRn_`
 943                      failWithRn Nothing err
 944                   Succeeded iface ->
 945                      --traceRn (ptext SLIT("parse cool"))     `thenRn_`
 946                      returnRn (Just iface)
 947
 948 #if __GLASGOW_HASKELL__ >= 202
 949         Left err ->
 950           if isDoesNotExistError err then
 951              --traceRn (ptext SLIT("no file"))     `thenRn_`
 952              returnRn Nothing
 953           else
 954              --traceRn (ptext SLIT("uh-oh.."))     `thenRn_`
 955              failWithRn Nothing (cannaeReadFile file_path err)
 956 #else /* 2.01 and 0.2x */
 957         Left  (NoSuchThing _) -> returnRn Nothing
 958
 959         Left  err             -> failWithRn Nothing
 960                                             (cannaeReadFile file_path err)
 961 #endif
 962
 963 \end{code}
 964
 965 mkSearchPath takes a string consisting of a colon-separated list
 966 of directories and corresponding suffixes, and turns it into a list
 967 of (directory, suffix) pairs.  For example:
 968
 969 \begin{verbatim}
 970  mkSearchPath "foo%.hi:.%.p_hi:baz%.mc_hi"
 971    = [("foo",".hi"),( ".", ".p_hi"), ("baz",".mc_hi")]
 972 \begin{verbatim}
 973
 974 \begin{code}
 975 mkSearchPath :: Maybe String -> SearchPath
 976 mkSearchPath Nothing = [(".",".hi")]
 977 mkSearchPath (Just s)
 978   = go s
 979   where
 980     go "" = []
 981     go s  =
 982       case span (/= '%') s of
 983        (dir,'%':rs) ->
 984          case span (/= ':') rs of
 985           (hisuf,_:rest) -> (dir,hisuf):go rest
 986           (hisuf,[])     -> [(dir,hisuf)]
 987 \end{code}
 988
 989 %*********************************************************
 990 %*                                                       *
 991 \subsection{Errors}
 992 %*                                                       *
 993 %*********************************************************
 994
 995 \begin{code}
 996 noIfaceErr filename sty
 997   = hcat [ptext SLIT("Could not find valid interface file "),
 998           quotes (pprModule sty filename)]
 999 --      , text " in"]) 4 (vcat (map text dirs))
1000
1001 cannaeReadFile file err sty
1002   = hcat [ptext SLIT("Failed in reading file: "),
1003            text file,
1004           ptext SLIT("; error="),
1005            text (show err)]
1006
1007 getDeclErr name sty
1008   = sep [ptext SLIT("Failed to find interface decl for"),
1009          ppr sty name]
1010
1011 getDeclWarn name sty
1012   = sep [ptext SLIT("Warning: failed to find (optional) interface decl for"),
1013          ppr sty name]
1014
1015 \end{code}