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