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