ghc/compiler/iface/LoadIface.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section{Dealing with interface files}
   5
   6 \begin{code}
   7 module LoadIface (
   8         loadHomeInterface, loadInterface, loadDecls,
   9         loadSrcInterface, loadOrphanModules, loadHiBootInterface,
  10         readIface,      -- Used when reading the module's old interface
  11         predInstGates, ifaceInstGates, ifaceStats, discardDeclPrags,
  12         initExternalPackageState
  13    ) where
  14
  15 #include "HsVersions.h"
  16
  17 import {-# SOURCE #-}   TcIface( tcIfaceDecl )
  18
  19 import Packages         ( PackageState(..), PackageIdH(..), isHomePackage )
  20 import DriverState      ( v_GhcMode, isCompManagerMode )
  21 import CmdLineOpts      ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) )
  22 import IfaceSyn         ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..),
  23                           IfaceConDecls(..), IfaceInst(..), IfaceRule(..),
  24                           IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..),
  25                           IfaceType(..), IfacePredType(..), IfaceExtName,
  26                           mkIfaceExtName )
  27 import IfaceEnv         ( newGlobalBinder, lookupIfaceExt, lookupIfaceTc,
  28                           lookupOrig )
  29 import HscTypes         ( ModIface(..), TyThing, emptyModIface, EpsStats(..),
  30                           addEpsInStats, ExternalPackageState(..),
  31                           PackageTypeEnv, emptyTypeEnv,
  32                           lookupIfaceByModule, emptyPackageIfaceTable,
  33                           IsBootInterface, mkIfaceFixCache, Gated,
  34                           implicitTyThings, addRulesToPool, addInstsToPool,
  35                           availNames
  36                          )
  37
  38 import BasicTypes       ( Version, Fixity(..), FixityDirection(..),
  39                           isMarkedStrict )
  40 import TcType           ( Type, tcSplitTyConApp_maybe )
  41 import Type             ( funTyCon )
  42 import TcRnMonad
  43
  44 import PrelNames        ( gHC_PRIM )
  45 import PrelInfo         ( ghcPrimExports )
  46 import PrelRules        ( builtinRules )
  47 import Rules            ( emptyRuleBase )
  48 import InstEnv          ( emptyInstEnv )
  49 import Name             ( Name {-instance NamedThing-}, getOccName,
  50                           nameModule, isInternalName )
  51 import NameEnv
  52 import MkId             ( seqId )
  53 import Module           ( Module, ModLocation(ml_hi_file), emptyModuleEnv,
  54                           addBootSuffix_maybe,
  55                           extendModuleEnv, lookupModuleEnv, moduleUserString
  56                         )
  57 import OccName          ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, mkClassDataConOcc,
  58                           mkSuperDictSelOcc, mkDataConWrapperOcc, mkDataConWorkerOcc )
  59 import Class            ( Class, className )
  60 import TyCon            ( tyConName )
  61 import SrcLoc           ( importedSrcLoc )
  62 import Maybes           ( mapCatMaybes, MaybeErr(..) )
  63 import FastString       ( mkFastString )
  64 import ErrUtils         ( Message )
  65 import Finder           ( findModule, findPackageModule,  FindResult(..), cantFindError )
  66 import Outputable
  67 import BinIface         ( readBinIface )
  68 import Panic            ( ghcError, tryMost, showException, GhcException(..) )
  69 import List             ( nub )
  70
  71 import DATA_IOREF       ( readIORef )
  72 \end{code}
  73
  74
  75 %************************************************************************
  76 %*                                                                      *
  77                 loadSrcInterface, loadOrphanModules
  78
  79                 These two are called from TcM-land
  80 %*                                                                      *
  81 %************************************************************************
  82
  83 \begin{code}
  84 loadSrcInterface :: SDoc -> Module -> IsBootInterface -> RnM ModIface
  85 -- This is called for each 'import' declaration in the source code
  86 -- On a failure, fail in the monad with an error message
  87
  88 loadSrcInterface doc mod_name want_boot
  89   = do  { mb_iface <- initIfaceTcRn $ loadInterface doc mod_name
  90                                            (ImportByUser want_boot)
  91         ; case mb_iface of
  92             Failed err      -> failWithTc (elaborate err)
  93             Succeeded iface -> return iface
  94         }
  95   where
  96     elaborate err = hang (ptext SLIT("Failed to load interface for") <+>
  97                          quotes (ppr mod_name) <> colon) 4 err
  98
  99 loadHiBootInterface :: TcRn [Name]
 100 -- Load the hi-boot iface for the module being compiled,
 101 -- if it indeed exists in the transitive closure of imports
 102 -- Return the list of names exported by the hi-boot file
 103 loadHiBootInterface
 104   = do  { eps <- getEps
 105         ; mod <- getModule
 106
 107         ; traceIf (text "loadHiBootInterface" <+> ppr mod)
 108
 109         -- We're read all the direct imports by now, so eps_is_boot will
 110         -- record if any of our imports mention us by way of hi-boot file
 111         ; case lookupModuleEnv (eps_is_boot eps) mod of {
 112             Nothing             -> return [] ;  -- The typical case
 113
 114             Just (_, False) ->          -- Someone below us imported us!
 115                 -- This is a loop with no hi-boot in the way
 116                 failWithTc (moduleLoop mod) ;
 117
 118             Just (mod_nm, True) ->      -- There's a hi-boot interface below us
 119
 120
 121     do  {       -- Load it (into the PTE), and return the exported names
 122           iface <- loadSrcInterface (mk_doc mod_nm) mod_nm True
 123         ; sequenceM [ lookupOrig mod_nm occ
 124                     | (mod,avails) <- mi_exports iface,
 125                       avail <- avails, occ <- availNames avail]
 126     }}}
 127   where
 128     mk_doc mod = ptext SLIT("Need the hi-boot interface for") <+> ppr mod
 129                  <+> ptext SLIT("to compare against the Real Thing")
 130
 131     moduleLoop mod = ptext SLIT("Circular imports: module") <+> quotes (ppr mod)
 132                      <+> ptext SLIT("depends on itself")
 133
 134 loadOrphanModules :: [Module] -> TcM ()
 135 loadOrphanModules mods
 136   | null mods = returnM ()
 137   | otherwise = initIfaceTcRn $
 138                 do { traceIf (text "Loading orphan modules:" <+>
 139                                  fsep (map ppr mods))
 140                    ; mappM_ load mods
 141                    ; returnM () }
 142   where
 143     load mod   = loadSysInterface (mk_doc mod) mod
 144     mk_doc mod = ppr mod <+> ptext SLIT("is a orphan-instance module")
 145 \end{code}
 146
 147 %*********************************************************
 148 %*                                                      *
 149                 loadHomeInterface
 150                 Called from Iface-land
 151 %*                                                      *
 152 %*********************************************************
 153
 154 \begin{code}
 155 loadHomeInterface :: SDoc -> Name -> IfM lcl ModIface
 156 loadHomeInterface doc name
 157   = ASSERT2( not (isInternalName name), ppr name <+> parens doc )
 158     loadSysInterface doc (nameModule name)
 159
 160 loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
 161 -- A wrapper for loadInterface that Throws an exception if it fails
 162 loadSysInterface doc mod_name
 163   = do  { mb_iface <- loadInterface doc mod_name ImportBySystem
 164         ; case mb_iface of
 165             Failed err      -> ghcError (ProgramError (showSDoc err))
 166             Succeeded iface -> return iface }
 167 \end{code}
 168
 169
 170 %*********************************************************
 171 %*                                                      *
 172                 loadInterface
 173
 174         The main function to load an interface
 175         for an imported module, and put it in
 176         the External Package State
 177 %*                                                      *
 178 %*********************************************************
 179
 180 \begin{code}
 181 loadInterface :: SDoc -> Module -> WhereFrom
 182               -> IfM lcl (MaybeErr Message ModIface)
 183 -- If it can't find a suitable interface file, we
 184 --      a) modify the PackageIfaceTable to have an empty entry
 185 --              (to avoid repeated complaints)
 186 --      b) return (Left message)
 187 --
 188 -- It's not necessarily an error for there not to be an interface
 189 -- file -- perhaps the module has changed, and that interface
 190 -- is no longer used
 191
 192 loadInterface doc_str mod from
 193   = do  {       -- Read the state
 194           (eps,hpt) <- getEpsAndHpt
 195
 196         ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from)
 197
 198                 -- Check whether we have the interface already
 199         ; case lookupIfaceByModule hpt (eps_PIT eps) mod of {
 200             Just iface
 201                 -> returnM (Succeeded iface) ;  -- Already loaded
 202                         -- The (src_imp == mi_boot iface) test checks that the already-loaded
 203                         -- interface isn't a boot iface.  This can conceivably happen,
 204                         -- if an earlier import had a before we got to real imports.   I think.
 205             other -> do
 206
 207         { let { hi_boot_file = case from of
 208                                 ImportByUser usr_boot -> usr_boot
 209                                 ImportBySystem        -> sys_boot
 210
 211               ; mb_dep   = lookupModuleEnv (eps_is_boot eps) mod
 212               ; sys_boot = case mb_dep of
 213                                 Just (_, is_boot) -> is_boot
 214                                 Nothing           -> False
 215                         -- The boot-ness of the requested interface,
 216               }         -- based on the dependencies in directly-imported modules
 217
 218         -- READ THE MODULE IN
 219         ; let explicit | ImportByUser _ <- from = True
 220                        | otherwise              = False
 221         ; read_result <- findAndReadIface explicit doc_str mod hi_boot_file
 222         ; dflags <- getDOpts
 223         ; case read_result of {
 224             Failed err -> do
 225                 { let fake_iface = emptyModIface HomePackage mod
 226
 227                 ; updateEps_ $ \eps ->
 228                         eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface }
 229                         -- Not found, so add an empty iface to
 230                         -- the EPS map so that we don't look again
 231
 232                 ; returnM (Failed err) } ;
 233
 234         -- Found and parsed!
 235             Succeeded (iface, file_path)                        -- Sanity check:
 236                 | ImportBySystem <- from,               --   system-importing...
 237                   isHomePackage (mi_package iface),     --   ...a home-package module
 238                   Nothing <- mb_dep                     --   ...that we know nothing about
 239                 -> returnM (Failed (badDepMsg mod))
 240
 241                 | otherwise ->
 242
 243         let
 244             loc_doc = text file_path <+> colon
 245         in
 246         initIfaceLcl mod loc_doc $ do
 247
 248         --      Load the new ModIface into the External Package State
 249         -- Even home-package interfaces loaded by loadInterface
 250         --      (which only happens in OneShot mode; in Batch/Interactive
 251         --      mode, home-package modules are loaded one by one into the HPT)
 252         -- are put in the EPS.
 253         --
 254         -- The main thing is to add the ModIface to the PIT, but
 255         -- we also take the
 256         --      IfaceDecls, IfaceInst, IfaceRules
 257         -- out of the ModIface and put them into the big EPS pools
 258
 259         -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined
 260         ---    names is done correctly (notably, whether this is an .hi file or .hi-boot file).
 261         --     If we do loadExport first the wrong info gets into the cache (unless we
 262         --      explicitly tag each export which seems a bit of a bore)
 263
 264         ; ignore_prags <- doptM Opt_IgnoreInterfacePragmas
 265         ; new_eps_decls <- loadDecls ignore_prags (mi_decls iface)
 266         ; new_eps_insts <- mapM loadInst (mi_insts iface)
 267         ; new_eps_rules <- if ignore_prags
 268                            then return []
 269                            else mapM loadRule (mi_rules iface)
 270
 271         ; let { final_iface = iface {   mi_decls = panic "No mi_decls in PIT",
 272                                         mi_insts = panic "No mi_insts in PIT",
 273                                         mi_rules = panic "No mi_rules in PIT" } }
 274
 275         ; updateEps_  $ \ eps ->
 276                 eps {   eps_PIT   = extendModuleEnv (eps_PIT eps) mod final_iface,
 277                         eps_PTE   = addDeclsToPTE   (eps_PTE eps) new_eps_decls,
 278                         eps_rules = addRulesToPool  (eps_rules eps) new_eps_rules,
 279                         eps_insts = addInstsToPool  (eps_insts eps) new_eps_insts,
 280                         eps_stats = addEpsInStats   (eps_stats eps) (length new_eps_decls)
 281                                                     (length new_eps_insts) (length new_eps_rules) }
 282
 283         ; return (Succeeded final_iface)
 284     }}}}
 285
 286 badDepMsg mod
 287   = hang (ptext SLIT("Interface file inconsistency:"))
 288        2 (sep [ptext SLIT("home-package module") <+> quotes (ppr mod) <+> ptext SLIT("is mentioned,"),
 289                ptext SLIT("but does not appear in the dependencies of the interface")])
 290
 291 -----------------------------------------------------
 292 --      Loading type/class/value decls
 293 -- We pass the full Module name here, replete with
 294 -- its package info, so that we can build a Name for
 295 -- each binder with the right package info in it
 296 -- All subsequent lookups, including crucially lookups during typechecking
 297 -- the declaration itself, will find the fully-glorious Name
 298 -----------------------------------------------------
 299
 300 addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv
 301 addDeclsToPTE pte things = extendNameEnvList pte things
 302
 303 loadDecls :: Bool
 304           -> [(Version, IfaceDecl)]
 305           -> IfL [(Name,TyThing)]
 306 loadDecls ignore_prags ver_decls
 307    = do { mod <- getIfModule
 308         ; thingss <- mapM (loadDecl ignore_prags mod) ver_decls
 309         ; return (concat thingss)
 310         }
 311
 312 loadDecl :: Bool                        -- Don't load pragmas into the decl pool
 313          -> Module
 314           -> (Version, IfaceDecl)
 315           -> IfL [(Name,TyThing)]       -- The list can be poked eagerly, but the
 316                                         -- TyThings are forkM'd thunks
 317 loadDecl ignore_prags mod (_version, decl)
 318   = do  {       -- Populate the name cache with final versions of all
 319                 -- the names associated with the decl
 320           main_name      <- mk_new_bndr mod Nothing (ifName decl)
 321         ; implicit_names <- mapM (mk_new_bndr mod (Just main_name)) (ifaceDeclSubBndrs decl)
 322
 323         -- Typecheck the thing, lazily
 324         -- NB. firstly, the laziness is there in case we never need the
 325         -- declaration (in one-shot mode), and secondly it is there so that
 326         -- we don't look up the occurrence of a name before calling mk_new_bndr
 327         -- on the binder.  This is important because we must get the right name
 328         -- which includes its nameParent.
 329         ; thing <- forkM doc (bumpDeclStats main_name >> tcIfaceDecl stripped_decl)
 330         ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]
 331               lookup n = case lookupOccEnv mini_env (getOccName n) of
 332                            Just thing -> thing
 333                            Nothing    -> pprPanic "loadDecl" (ppr main_name <+> ppr n)
 334
 335         ; returnM ((main_name, thing) : [(n, lookup n) | n <- implicit_names]) }
 336                 -- We build a list from the *known* names, with (lookup n) thunks
 337                 -- as the TyThings.  That way we can extend the PTE without poking the
 338                 -- thunks
 339   where
 340     stripped_decl | ignore_prags = discardDeclPrags decl
 341                   | otherwise    = decl
 342
 343         -- mk_new_bndr allocates in the name cache the final canonical
 344         -- name for the thing, with the correct
 345         --      * parent
 346         --      * location
 347         -- imported name, to fix the module correctly in the cache
 348     mk_new_bndr mod mb_parent occ
 349         = newGlobalBinder mod occ mb_parent
 350                           (importedSrcLoc (moduleUserString mod))
 351
 352     doc = ptext SLIT("Declaration for") <+> ppr (ifName decl)
 353
 354 discardDeclPrags :: IfaceDecl -> IfaceDecl
 355 discardDeclPrags decl@(IfaceId {ifIdInfo = HasInfo _}) = decl { ifIdInfo = NoInfo }
 356 discardDeclPrags decl                                  = decl
 357
 358 bumpDeclStats :: Name -> IfL ()         -- Record that one more declaration has actually been used
 359 bumpDeclStats name
 360   = do  { traceIf (text "Loading decl for" <+> ppr name)
 361         ; updateEps_ (\eps -> let stats = eps_stats eps
 362                               in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })
 363         }
 364
 365 -----------------
 366 ifaceDeclSubBndrs :: IfaceDecl -> [OccName]
 367 -- *Excludes* the 'main' name, but *includes* the implicitly-bound names
 368 -- Deeply revolting, because it has to predict what gets bound,
 369 -- especially the question of whether there's a wrapper for a datacon
 370
 371 ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, ifSigs = sigs })
 372   = [tc_occ, dc_occ, dcww_occ] ++
 373     [op | IfaceClassOp op _ _ <- sigs] ++
 374     [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]]
 375   where
 376     n_ctxt = length sc_ctxt
 377     n_sigs = length sigs
 378     tc_occ  = mkClassTyConOcc cls_occ
 379     dc_occ  = mkClassDataConOcc cls_occ
 380     dcww_occ | is_newtype = mkDataConWrapperOcc dc_occ  -- Newtypes have wrapper but no worker
 381              | otherwise  = mkDataConWorkerOcc dc_occ   -- Otherwise worker but no wrapper
 382     is_newtype = n_sigs + n_ctxt == 1                   -- Sigh
 383
 384 ifaceDeclSubBndrs (IfaceData {ifCons = IfAbstractTyCon})
 385   = []
 386 -- Newtype
 387 ifaceDeclSubBndrs (IfaceData {ifCons = IfNewTyCon (IfVanillaCon { ifConOcc = con_occ,
 388                                                                   ifConFields = fields})})
 389   = fields ++ [con_occ, mkDataConWrapperOcc con_occ]
 390         -- Wrapper, no worker; see MkId.mkDataConIds
 391
 392 ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon _ cons})
 393   = nub (concatMap fld_occs cons)       -- Eliminate duplicate fields
 394     ++ concatMap dc_occs cons
 395   where
 396     fld_occs (IfVanillaCon { ifConFields = fields }) = fields
 397     fld_occs (IfGadtCon {})                          = []
 398     dc_occs con_decl
 399         | has_wrapper = [con_occ, work_occ, wrap_occ]
 400         | otherwise   = [con_occ, work_occ]
 401         where
 402           con_occ = ifConOcc con_decl
 403           strs    = ifConStricts con_decl
 404           wrap_occ = mkDataConWrapperOcc con_occ
 405           work_occ = mkDataConWorkerOcc con_occ
 406           has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh)
 407                 -- ToDo: may miss strictness in existential dicts
 408
 409 ifaceDeclSubBndrs _other                      = []
 410
 411 -----------------------------------------------------
 412 --      Loading instance decls
 413 -----------------------------------------------------
 414
 415 loadInst :: IfaceInst -> IfL (Name, Gated IfaceInst)
 416
 417 loadInst decl@(IfaceInst {ifInstHead = inst_ty})
 418   = do  {
 419         -- Find out what type constructors and classes are "gates" for the
 420         -- instance declaration.  If all these "gates" are slurped in then
 421         -- we should slurp the instance decl too.
 422         --
 423         -- We *don't* want to count names in the context part as gates, though.
 424         -- For example:
 425         --              instance Foo a => Baz (T a) where ...
 426         --
 427         -- Here the gates are Baz and T, but *not* Foo.
 428         --
 429         -- HOWEVER: functional dependencies make things more complicated
 430         --      class C a b | a->b where ...
 431         --      instance C Foo Baz where ...
 432         -- Here, the gates are really only C and Foo, *not* Baz.
 433         -- That is, if C and Foo are visible, even if Baz isn't, we must
 434         -- slurp the decl.
 435         --
 436         -- Rather than take fundeps into account "properly", we just slurp
 437         -- if C is visible and *any one* of the Names in the types
 438         -- This is a slightly brutal approximation, but most instance decls
 439         -- are regular H98 ones and it's perfect for them.
 440         --
 441         -- NOTICE that we rename the type before extracting its free
 442         -- variables.  The free-variable finder for a renamed HsType
 443         -- does the Right Thing for built-in syntax like [] and (,).
 444           let { (cls_ext, tc_exts) = ifaceInstGates inst_ty }
 445         ; cls <- lookupIfaceExt cls_ext
 446         ; tcs <- mapM lookupIfaceTc tc_exts
 447         ; (mod, doc) <- getIfCtxt
 448         ; returnM (cls, (tcs, (mod, doc, decl)))
 449         }
 450
 451 -----------------------------------------------------
 452 --      Loading Rules
 453 -----------------------------------------------------
 454
 455 loadRule :: IfaceRule -> IfL (Gated IfaceRule)
 456 -- "Gate" the rule simply by a crude notion of the free vars of
 457 -- the LHS.  It can be crude, because having too few free vars is safe.
 458 loadRule decl@(IfaceRule {ifRuleHead = fn, ifRuleArgs = args})
 459   = do  { names <- mapM lookupIfaceExt (fn : arg_fvs)
 460         ; (mod, doc) <- getIfCtxt
 461         ; returnM (names, (mod, doc, decl)) }
 462   where
 463     arg_fvs = [n | arg <- args, n <- crudeIfExprGblFvs arg]
 464
 465
 466 ---------------------------
 467 crudeIfExprGblFvs :: IfaceExpr -> [IfaceExtName]
 468 -- A crude approximation to the free external names of an IfExpr
 469 -- Returns a subset of the true answer
 470 crudeIfExprGblFvs (IfaceType ty) = get_tcs ty
 471 crudeIfExprGblFvs (IfaceExt v)   = [v]
 472 crudeIfExprGblFvs other          = []   -- Well, I said it was crude
 473
 474 get_tcs :: IfaceType -> [IfaceExtName]
 475 -- Get a crude subset of the TyCons of an IfaceType
 476 get_tcs (IfaceTyVar _)      = []
 477 get_tcs (IfaceAppTy t1 t2)  = get_tcs t1 ++ get_tcs t2
 478 get_tcs (IfaceFunTy t1 t2)  = get_tcs t1 ++ get_tcs t2
 479 get_tcs (IfaceForAllTy _ t) = get_tcs t
 480 get_tcs (IfacePredTy st)    = case st of
 481                                  IfaceClassP cl ts -> get_tcs_s ts
 482                                  IfaceIParam _ t   -> get_tcs t
 483 get_tcs (IfaceTyConApp (IfaceTc tc) ts) = tc : get_tcs_s ts
 484 get_tcs (IfaceTyConApp other        ts) = get_tcs_s ts
 485
 486 -- The lists are always small => appending is fine
 487 get_tcs_s :: [IfaceType] -> [IfaceExtName]
 488 get_tcs_s tys = foldr ((++) . get_tcs) [] tys
 489
 490
 491 ----------------
 492 getIfCtxt :: IfL (Module, SDoc)
 493 getIfCtxt = do { env <- getLclEnv; return (if_mod env, if_loc env) }
 494 \end{code}
 495
 496
 497 %*********************************************************
 498 %*                                                      *
 499                 Gating
 500 %*                                                      *
 501 %*********************************************************
 502
 503 Extract the gates of an instance declaration
 504
 505 \begin{code}
 506 ifaceInstGates :: IfaceType -> (IfaceExtName, [IfaceTyCon])
 507 -- Return the class, and the tycons mentioned in the rest of the head
 508 -- We only pick the TyCon at the root of each type, to avoid
 509 -- difficulties with overlap.  For example, suppose there are interfaces
 510 -- in the pool for
 511 --      C Int b
 512 --      C a [b]
 513 --      C a [T]
 514 -- Then, if we are trying to resolve (C Int x), we need the first
 515 --       if we are trying to resolve (C x [y]), we need *both* the latter
 516 --       two, even though T is not involved yet, so that we spot the overlap
 517
 518 ifaceInstGates (IfaceForAllTy _ t)                 = ifaceInstGates t
 519 ifaceInstGates (IfaceFunTy _ t)                    = ifaceInstGates t
 520 ifaceInstGates (IfacePredTy (IfaceClassP cls tys)) = (cls, instHeadTyconGates tys)
 521 ifaceInstGates other = pprPanic "ifaceInstGates" (ppr other)
 522         -- The other cases should not happen
 523
 524 instHeadTyconGates tys = mapCatMaybes root_tycon tys
 525   where
 526     root_tycon (IfaceFunTy _ _)      = Just (IfaceTc funTyConExtName)
 527     root_tycon (IfaceTyConApp tc _)  = Just tc
 528     root_tycon other                 = Nothing
 529
 530 funTyConExtName = mkIfaceExtName (tyConName funTyCon)
 531
 532
 533 predInstGates :: Class -> [Type] -> (Name, [Name])
 534 -- The same function, only this time on the predicate found in a dictionary
 535 predInstGates cls tys
 536   = (className cls, mapCatMaybes root_tycon tys)
 537   where
 538     root_tycon ty = case tcSplitTyConApp_maybe ty of
 539                         Just (tc, _) -> Just (tyConName tc)
 540                         Nothing      -> Nothing
 541 \end{code}
 542
 543
 544 %*********************************************************
 545 %*                                                      *
 546 \subsection{Reading an interface file}
 547 %*                                                      *
 548 %*********************************************************
 549
 550 \begin{code}
 551 findAndReadIface :: Bool                -- True <=> explicit user import
 552                  -> SDoc -> Module
 553                  -> IsBootInterface     -- True  <=> Look for a .hi-boot file
 554                                         -- False <=> Look for .hi file
 555                  -> IfM lcl (MaybeErr Message (ModIface, FilePath))
 556         -- Nothing <=> file not found, or unreadable, or illegible
 557         -- Just x  <=> successfully found and parsed
 558
 559         -- It *doesn't* add an error to the monad, because
 560         -- sometimes it's ok to fail... see notes with loadInterface
 561
 562 findAndReadIface explicit doc_str mod_name hi_boot_file
 563   = do  { traceIf (sep [hsep [ptext SLIT("Reading"),
 564                               if hi_boot_file
 565                                 then ptext SLIT("[boot]")
 566                                 else empty,
 567                               ptext SLIT("interface for"),
 568                               ppr mod_name <> semi],
 569                         nest 4 (ptext SLIT("reason:") <+> doc_str)])
 570
 571         -- Check for GHC.Prim, and return its static interface
 572         ; dflags <- getDOpts
 573         ; let base_pkg = basePackageId (pkgState dflags)
 574         ; if mod_name == gHC_PRIM
 575           then returnM (Succeeded (ghcPrimIface{ mi_package = base_pkg },
 576                         "<built in interface for GHC.Prim>"))
 577           else do
 578
 579         -- Look for the file
 580         ; mb_found <- ioToIOEnv (findHiFile dflags explicit mod_name hi_boot_file)
 581         ; case mb_found of {
 582               Failed err -> do
 583                 { traceIf (ptext SLIT("...not found"))
 584                 ; dflags <- getDOpts
 585                 ; returnM (Failed (cantFindError dflags mod_name err)) } ;
 586
 587               Succeeded (file_path, pkg) -> do
 588
 589         -- Found file, so read it
 590         { traceIf (ptext SLIT("readIFace") <+> text file_path)
 591         ; read_result <- readIface mod_name file_path hi_boot_file
 592         ; case read_result of
 593             Failed err -> returnM (Failed (badIfaceFile file_path err))
 594             Succeeded iface
 595                 | mi_module iface /= mod_name ->
 596                   return (Failed (wrongIfaceModErr iface mod_name file_path))
 597                 | otherwise ->
 598                   returnM (Succeeded (iface{mi_package=pkg}, file_path))
 599                         -- Don't forget to fill in the package name...
 600         }}}
 601
 602 findHiFile :: DynFlags -> Bool -> Module -> IsBootInterface
 603            -> IO (MaybeErr FindResult (FilePath, PackageIdH))
 604 findHiFile dflags explicit mod_name hi_boot_file
 605  = do {
 606         -- In interactive or --make mode, we are *not allowed* to demand-load
 607         -- a home package .hi file.  So don't even look for them.
 608         -- This helps in the case where you are sitting in eg. ghc/lib/std
 609         -- and start up GHCi - it won't complain that all the modules it tries
 610         -- to load are found in the home location.
 611         ghci_mode <- readIORef v_GhcMode ;
 612         let { home_allowed = not (isCompManagerMode ghci_mode) } ;
 613         maybe_found <-  if home_allowed
 614                         then findModule        dflags mod_name explicit
 615                         else findPackageModule dflags mod_name explicit;
 616
 617         case maybe_found of
 618           Found loc pkg -> return (Succeeded (path, pkg))
 619                         where
 620                            path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc)
 621
 622           err -> return (Failed err)
 623         }
 624 \end{code}
 625
 626 @readIface@ tries just the one file.
 627
 628 \begin{code}
 629 readIface :: Module -> String -> IsBootInterface
 630           -> IfM lcl (MaybeErr Message ModIface)
 631         -- Failed err    <=> file not found, or unreadable, or illegible
 632         -- Succeeded iface <=> successfully found and parsed
 633
 634 readIface wanted_mod file_path is_hi_boot_file
 635   = do  { dflags <- getDOpts
 636         ; ioToIOEnv $ do
 637         { res <- tryMost (readBinIface file_path)
 638         ; case res of
 639             Right iface
 640                 | wanted_mod == actual_mod -> return (Succeeded iface)
 641                 | otherwise                -> return (Failed err)
 642                 where
 643                   actual_mod = mi_module iface
 644                   err = hiModuleNameMismatchWarn wanted_mod actual_mod
 645
 646             Left exn    -> return (Failed (text (showException exn)))
 647     }}
 648 \end{code}
 649
 650
 651 %*********************************************************
 652 %*                                                       *
 653         Wired-in interface for GHC.Prim
 654 %*                                                       *
 655 %*********************************************************
 656
 657 \begin{code}
 658 initExternalPackageState :: ExternalPackageState
 659 initExternalPackageState
 660   = EPS {
 661       eps_is_boot    = emptyModuleEnv,
 662       eps_PIT        = emptyPackageIfaceTable,
 663       eps_PTE        = emptyTypeEnv,
 664       eps_inst_env   = emptyInstEnv,
 665       eps_rule_base  = emptyRuleBase,
 666       eps_insts      = emptyNameEnv,
 667       eps_rules      = addRulesToPool [] (map mk_gated_rule builtinRules),
 668         -- Initialise the EPS rule pool with the built-in rules
 669       eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0
 670                            , n_insts_in = 0, n_insts_out = 0
 671                            , n_rules_in = length builtinRules, n_rules_out = 0 }
 672     }
 673   where
 674     mk_gated_rule (fn_name, core_rule)
 675         = ([fn_name], (nameModule fn_name, ptext SLIT("<built-in rule>"),
 676            IfaceBuiltinRule (mkIfaceExtName fn_name) core_rule))
 677 \end{code}
 678
 679
 680 %*********************************************************
 681 %*                                                       *
 682         Wired-in interface for GHC.Prim
 683 %*                                                       *
 684 %*********************************************************
 685
 686 \begin{code}
 687 ghcPrimIface :: ModIface
 688 ghcPrimIface
 689   = (emptyModIface HomePackage gHC_PRIM) {
 690         mi_exports  = [(gHC_PRIM, ghcPrimExports)],
 691         mi_decls    = [],
 692         mi_fixities = fixities,
 693         mi_fix_fn  = mkIfaceFixCache fixities
 694     }
 695   where
 696     fixities = [(getOccName seqId, Fixity 0 InfixR)]
 697                         -- seq is infixr 0
 698 \end{code}
 699
 700 %*********************************************************
 701 %*                                                      *
 702 \subsection{Statistics}
 703 %*                                                      *
 704 %*********************************************************
 705
 706 \begin{code}
 707 ifaceStats :: ExternalPackageState -> SDoc
 708 ifaceStats eps
 709   = hcat [text "Renamer stats: ", msg]
 710   where
 711     stats = eps_stats eps
 712     msg = vcat
 713         [int (n_ifaces_in stats) <+> text "interfaces read",
 714          hsep [ int (n_decls_out stats), text "type/class/variable imported, out of",
 715                 int (n_decls_in stats), text "read"],
 716          hsep [ int (n_insts_out stats), text "instance decls imported, out of",
 717                 int (n_insts_in stats), text "read"],
 718          hsep [ int (n_rules_out stats), text "rule decls imported, out of",
 719                 int (n_rules_in stats), text "read"]
 720         ]
 721 \end{code}
 722
 723
 724 %*********************************************************
 725 %*                                                       *
 726 \subsection{Errors}
 727 %*                                                       *
 728 %*********************************************************
 729
 730 \begin{code}
 731 badIfaceFile file err
 732   = vcat [ptext SLIT("Bad interface file:") <+> text file,
 733           nest 4 err]
 734
 735 hiModuleNameMismatchWarn :: Module -> Module -> Message
 736 hiModuleNameMismatchWarn requested_mod read_mod =
 737     hsep [ ptext SLIT("Something is amiss; requested module name")
 738          , ppr requested_mod
 739          , ptext SLIT("differs from name found in the interface file")
 740          , ppr read_mod
 741          ]
 742
 743 wrongIfaceModErr iface mod_name file_path
 744   = sep [ptext SLIT("Interface file") <+> iface_file,
 745          ptext SLIT("contains module") <+> quotes (ppr (mi_module iface)) <> comma,
 746          ptext SLIT("but we were expecting module") <+> quotes (ppr mod_name),
 747          sep [ptext SLIT("Probable cause: the source code which generated"),
 748              nest 2 iface_file,
 749              ptext SLIT("has an incompatible module name")
 750             ]
 751         ]
 752   where iface_file = doubleQuotes (text file_path)
 753 \end{code}