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