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(..), isHomeModule  )
  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,  IfacePackage(..),
  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           ( isJust, mapCatMaybes )
  66 import StringBuffer     ( hGetStringBuffer )
  67 import FastString       ( mkFastString )
  68 import ErrUtils         ( Message, mkLocMessage )
  69 import Finder           ( findModule, findPackageModule,  FindResult(..),
  70                           hiBootExt, hiBootVerExt )
  71 import Lexer
  72 import Outputable
  73 import BinIface         ( readBinIface )
  74 import Panic
  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             Left err    -> failWithTc (elaborate err)
 101             Right 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             Left err    -> ghcError (ProgramError (showSDoc err))
 174             Right 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 (Either 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 -- but the caller can deal with that by
 199 -- catching the exception
 200
 201 loadInterface doc_str mod_name from
 202   = do  {       -- Read the state
 203           (eps,hpt) <- getEpsAndHpt
 204
 205         ; traceIf (text "Considering whether to load" <+> ppr mod_name <+> ppr from)
 206
 207                 -- Check whether we have the interface already
 208         ; case lookupIfaceByModule hpt (eps_PIT eps) mod_name of {
 209             Just iface
 210                 -> returnM (Right iface) ;      -- Already loaded
 211                         -- The (src_imp == mi_boot iface) test checks that the already-loaded
 212                         -- interface isn't a boot iface.  This can conceivably happen,
 213                         -- if an earlier import had a before we got to real imports.   I think.
 214             other -> do
 215
 216         { let { hi_boot_file = case from of
 217                                 ImportByUser usr_boot -> usr_boot
 218                                 ImportBySystem        -> sys_boot
 219
 220               ; mb_dep   = lookupModuleEnv (eps_is_boot eps) mod_name
 221               ; sys_boot = case mb_dep of
 222                                 Just (_, is_boot) -> is_boot
 223                                 Nothing           -> False
 224                         -- The boot-ness of the requested interface,
 225               }         -- based on the dependencies in directly-imported modules
 226
 227         -- READ THE MODULE IN
 228         ; let explicit | ImportByUser _ <- from = True
 229                        | otherwise              = False
 230         ; read_result <- findAndReadIface explicit doc_str mod_name hi_boot_file
 231         ; dflags <- getDOpts
 232         ; case read_result of {
 233             Left err -> do
 234                 { let fake_iface = emptyModIface ThisPackage mod_name
 235
 236                 ; updateEps_ $ \eps ->
 237                         eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface }
 238                         -- Not found, so add an empty iface to
 239                         -- the EPS map so that we don't look again
 240
 241                 ; returnM (Left err) } ;
 242
 243         -- Found and parsed!
 244             Right iface ->
 245
 246         let { mod = mi_module iface } in
 247
 248         -- Sanity check.  If we're system-importing a module we know nothing at all
 249         -- about, it should be from a different package to this one
 250         WARN(   case from of { ImportBySystem -> True; other -> False } &&
 251                 not (isJust mb_dep) &&
 252                 isHomeModule dflags mod,
 253                 ppr mod $$ ppr mb_dep $$ ppr (eps_is_boot eps) )
 254
 255         initIfaceLcl mod_name $ do
 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 <- loadDecls ignore_prags mod      (mi_decls iface)
 274         ; new_eps_rules <- loadRules ignore_prags mod_name (mi_rules iface)
 275         ; new_eps_insts <- loadInsts              mod_name (mi_insts iface)
 276
 277         ; let { final_iface = iface {   mi_decls = panic "No mi_decls in PIT",
 278                                         mi_insts = panic "No mi_insts in PIT",
 279                                         mi_rules = panic "No mi_rules in PIT" } }
 280
 281         ; updateEps_  $ \ eps ->
 282                 eps {   eps_PIT   = extendModuleEnv (eps_PIT eps) mod final_iface,
 283                         eps_PTE   = addDeclsToPTE   (eps_PTE eps) new_eps_decls,
 284                         eps_rules = addRulesToPool  (eps_rules eps) new_eps_rules,
 285                         eps_insts = addInstsToPool  (eps_insts eps) new_eps_insts,
 286                         eps_stats = addEpsInStats   (eps_stats eps) (length new_eps_decls)
 287                                                     (length new_eps_insts) (length new_eps_rules) }
 288
 289         ; return (Right final_iface)
 290     }}}}}
 291
 292 -----------------------------------------------------
 293 --      Loading type/class/value decls
 294 -- We pass the full Module name here, replete with
 295 -- its package info, so that we can build a Name for
 296 -- each binder with the right package info in it
 297 -- All subsequent lookups, including crucially lookups during typechecking
 298 -- the declaration itself, will find the fully-glorious Name
 299 -----------------------------------------------------
 300
 301 addDeclsToPTE :: PackageTypeEnv -> [[(Name,TyThing)]] -> PackageTypeEnv
 302 addDeclsToPTE pte things = foldl extendNameEnvList pte things
 303
 304 loadDecls :: Bool       -- Don't load pragmas into the decl pool
 305           -> Module
 306           -> [(Version, IfaceDecl)]
 307           -> IfL [[(Name,TyThing)]]     -- The list can be poked eagerly, but the
 308                                         -- TyThings are forkM'd thunks
 309 loadDecls ignore_prags mod decls = mapM (loadDecl ignore_prags mod) decls
 310
 311 loadDecl ignore_prags mod (_version, decl)
 312   = do  {       -- Populate the name cache with final versions of all
 313                 -- the names associated with the decl
 314           main_name      <- mk_new_bndr Nothing (ifName decl)
 315         ; implicit_names <- mapM (mk_new_bndr (Just main_name)) (ifaceDeclSubBndrs decl)
 316
 317         -- Typecheck the thing, lazily
 318         ; thing <- forkM doc (bumpDeclStats main_name >> tcIfaceDecl stripped_decl)
 319         ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]
 320               lookup n = case lookupOccEnv mini_env (getOccName n) of
 321                            Just thing -> thing
 322                            Nothing    -> pprPanic "loadDecl" (ppr main_name <+> ppr n)
 323
 324         ; returnM ((main_name, thing) : [(n, lookup n) | n <- implicit_names]) }
 325                 -- We build a list from the *known* names, with (lookup n) thunks
 326                 -- as the TyThings.  That way we can extend the PTE without poking the
 327                 -- thunks
 328   where
 329     stripped_decl | ignore_prags = discardDeclPrags decl
 330                   | otherwise    = decl
 331
 332         -- mk_new_bndr allocates in the name cache the final canonical
 333         -- name for the thing, with the correct
 334         --      * package info
 335         --      * parent
 336         --      * location
 337         -- imported name, to fix the module correctly in the cache
 338     mk_new_bndr mb_parent occ = newGlobalBinder mod occ mb_parent loc
 339     loc = importedSrcLoc (moduleUserString mod)
 340     doc = ptext SLIT("Declaration for") <+> ppr (ifName decl)
 341
 342 discardDeclPrags :: IfaceDecl -> IfaceDecl
 343 discardDeclPrags decl@(IfaceId {ifIdInfo = HasInfo _}) = decl { ifIdInfo = NoInfo }
 344 discardDeclPrags decl                                  = decl
 345
 346 bumpDeclStats :: Name -> IfL ()         -- Record that one more declaration has actually been used
 347 bumpDeclStats name
 348   = do  { traceIf (text "Loading decl for" <+> ppr name)
 349         ; updateEps_ (\eps -> let stats = eps_stats eps
 350                               in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })
 351         }
 352
 353 -----------------
 354 ifaceDeclSubBndrs :: IfaceDecl -> [OccName]
 355 -- *Excludes* the 'main' name, but *includes* the implicitly-bound names
 356 -- Deeply revolting, because it has to predict what gets bound,
 357 -- especially the question of whether there's a wrapper for a datacon
 358
 359 ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, ifSigs = sigs })
 360   = [tc_occ, dc_occ, dcww_occ] ++
 361     [op | IfaceClassOp op _ _ <- sigs] ++
 362     [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]]
 363   where
 364     n_ctxt = length sc_ctxt
 365     n_sigs = length sigs
 366     tc_occ  = mkClassTyConOcc cls_occ
 367     dc_occ  = mkClassDataConOcc cls_occ
 368     dcww_occ | is_newtype = mkDataConWrapperOcc dc_occ  -- Newtypes have wrapper but no worker
 369              | otherwise  = mkDataConWorkerOcc dc_occ   -- Otherwise worker but no wrapper
 370     is_newtype = n_sigs + n_ctxt == 1                   -- Sigh
 371
 372 ifaceDeclSubBndrs (IfaceData {ifCons = IfAbstractTyCon})
 373   = []
 374 -- Newtype
 375 ifaceDeclSubBndrs (IfaceData {ifCons = IfNewTyCon (IfVanillaCon { ifConOcc = con_occ,
 376                                                                   ifConFields = fields})})
 377   = fields ++ [con_occ, mkDataConWrapperOcc con_occ]
 378         -- Wrapper, no worker; see MkId.mkDataConIds
 379
 380 ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon _ cons})
 381   = nub (concatMap fld_occs cons)       -- Eliminate duplicate fields
 382     ++ concatMap dc_occs cons
 383   where
 384     fld_occs (IfVanillaCon { ifConFields = fields }) = fields
 385     fld_occs (IfGadtCon {})                          = []
 386     dc_occs con_decl
 387         | has_wrapper = [con_occ, work_occ, wrap_occ]
 388         | otherwise   = [con_occ, work_occ]
 389         where
 390           con_occ = ifConOcc con_decl
 391           strs    = ifConStricts con_decl
 392           wrap_occ = mkDataConWrapperOcc con_occ
 393           work_occ = mkDataConWorkerOcc con_occ
 394           has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh)
 395                 -- ToDo: may miss strictness in existential dicts
 396
 397 ifaceDeclSubBndrs _other                      = []
 398
 399 -----------------------------------------------------
 400 --      Loading instance decls
 401 -----------------------------------------------------
 402
 403 loadInsts :: Module -> [IfaceInst] -> IfL [(Name, Gated IfaceInst)]
 404 loadInsts mod decls = mapM (loadInstDecl mod) decls
 405
 406 loadInstDecl mod decl@(IfaceInst {ifInstHead = inst_ty})
 407   = do  {
 408         -- Find out what type constructors and classes are "gates" for the
 409         -- instance declaration.  If all these "gates" are slurped in then
 410         -- we should slurp the instance decl too.
 411         --
 412         -- We *don't* want to count names in the context part as gates, though.
 413         -- For example:
 414         --              instance Foo a => Baz (T a) where ...
 415         --
 416         -- Here the gates are Baz and T, but *not* Foo.
 417         --
 418         -- HOWEVER: functional dependencies make things more complicated
 419         --      class C a b | a->b where ...
 420         --      instance C Foo Baz where ...
 421         -- Here, the gates are really only C and Foo, *not* Baz.
 422         -- That is, if C and Foo are visible, even if Baz isn't, we must
 423         -- slurp the decl.
 424         --
 425         -- Rather than take fundeps into account "properly", we just slurp
 426         -- if C is visible and *any one* of the Names in the types
 427         -- This is a slightly brutal approximation, but most instance decls
 428         -- are regular H98 ones and it's perfect for them.
 429         --
 430         -- NOTICE that we rename the type before extracting its free
 431         -- variables.  The free-variable finder for a renamed HsType
 432         -- does the Right Thing for built-in syntax like [] and (,).
 433           let { (cls_ext, tc_exts) = ifaceInstGates inst_ty }
 434         ; cls <- lookupIfaceExt cls_ext
 435         ; tcs <- mapM lookupIfaceTc tc_exts
 436         ; returnM (cls, (tcs, (mod,decl)))
 437         }
 438
 439 -----------------------------------------------------
 440 --      Loading Rules
 441 -----------------------------------------------------
 442
 443 loadRules :: Bool       -- Don't load pragmas into the decl pool
 444           -> Module
 445           -> [IfaceRule] -> IfL [Gated IfaceRule]
 446 loadRules ignore_prags mod rules
 447   | ignore_prags = returnM []
 448   | otherwise    = mapM (loadRule mod) rules
 449
 450 loadRule :: Module -> IfaceRule -> IfL (Gated IfaceRule)
 451 -- "Gate" the rule simply by a crude notion of the free vars of
 452 -- the LHS.  It can be crude, because having too few free vars is safe.
 453 loadRule mod decl@(IfaceRule {ifRuleHead = fn, ifRuleArgs = args})
 454   = do  { names <- mapM lookupIfaceExt (fn : arg_fvs)
 455         ; returnM (names, (mod, 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 \end{code}
 484
 485
 486 %*********************************************************
 487 %*                                                      *
 488                 Gating
 489 %*                                                      *
 490 %*********************************************************
 491
 492 Extract the gates of an instance declaration
 493
 494 \begin{code}
 495 ifaceInstGates :: IfaceType -> (IfaceExtName, [IfaceTyCon])
 496 -- Return the class, and the tycons mentioned in the rest of the head
 497 -- We only pick the TyCon at the root of each type, to avoid
 498 -- difficulties with overlap.  For example, suppose there are interfaces
 499 -- in the pool for
 500 --      C Int b
 501 --      C a [b]
 502 --      C a [T]
 503 -- Then, if we are trying to resolve (C Int x), we need the first
 504 --       if we are trying to resolve (C x [y]), we need *both* the latter
 505 --       two, even though T is not involved yet, so that we spot the overlap
 506
 507 ifaceInstGates (IfaceForAllTy _ t)                 = ifaceInstGates t
 508 ifaceInstGates (IfaceFunTy _ t)                    = ifaceInstGates t
 509 ifaceInstGates (IfacePredTy (IfaceClassP cls tys)) = instHeadGates cls tys
 510 ifaceInstGates other = pprPanic "ifaceInstGates" (ppr other)
 511         -- The other cases should not happen
 512
 513 instHeadGates cls tys = (cls, mapCatMaybes root_tycon tys)
 514   where
 515     root_tycon (IfaceFunTy _ _)      = Just (IfaceTc funTyConExtName)
 516     root_tycon (IfaceTyConApp tc _)  = Just tc
 517     root_tycon other                 = Nothing
 518
 519 funTyConExtName = mkIfaceExtName (tyConName funTyCon)
 520
 521
 522 predInstGates :: Class -> [Type] -> (Name, [Name])
 523 -- The same function, only this time on the predicate found in a dictionary
 524 predInstGates cls tys
 525   = (className cls, mapCatMaybes root_tycon tys)
 526   where
 527     root_tycon ty = case tcSplitTyConApp_maybe ty of
 528                         Just (tc, _) -> Just (tyConName tc)
 529                         Nothing      -> Nothing
 530 \end{code}
 531
 532
 533 %*********************************************************
 534 %*                                                      *
 535 \subsection{Reading an interface file}
 536 %*                                                      *
 537 %*********************************************************
 538
 539 \begin{code}
 540 findAndReadIface :: Bool                -- True <=> explicit user import
 541                  -> SDoc -> Module
 542                  -> IsBootInterface     -- True  <=> Look for a .hi-boot file
 543                                         -- False <=> Look for .hi file
 544                  -> IfM lcl (Either Message ModIface)
 545         -- Nothing <=> file not found, or unreadable, or illegible
 546         -- Just x  <=> successfully found and parsed
 547
 548         -- It *doesn't* add an error to the monad, because
 549         -- sometimes it's ok to fail... see notes with loadInterface
 550
 551 findAndReadIface explicit doc_str mod_name hi_boot_file
 552   = do  { traceIf (sep [hsep [ptext SLIT("Reading"),
 553                               if hi_boot_file
 554                                 then ptext SLIT("[boot]")
 555                                 else empty,
 556                               ptext SLIT("interface for"),
 557                               ppr mod_name <> semi],
 558                         nest 4 (ptext SLIT("reason:") <+> doc_str)])
 559
 560         -- Check for GHC.Prim, and return its static interface
 561         ; dflags <- getDOpts
 562         ; let base_id = basePackageId (pkgState dflags)
 563               base_pkg
 564                 | Just id <- base_id = ExternalPackage id
 565                 | otherwise          = ThisPackage
 566                 -- if basePackageId is Nothing, it means we must be
 567                 -- compiling the base package.
 568         ; if mod_name == gHC_PRIM
 569           then returnM (Right (ghcPrimIface{ mi_package = base_pkg }))
 570           else do
 571
 572         -- Look for the file
 573         ; mb_found <- ioToIOEnv (findHiFile dflags explicit mod_name hi_boot_file)
 574         ; case mb_found of {
 575               Left err -> do
 576                 { traceIf (ptext SLIT("...not found"))
 577                 ; dflags <- getDOpts
 578                 ; returnM (Left (noIfaceErr dflags mod_name err)) } ;
 579
 580               Right (file_path,pkg) -> do
 581
 582         -- Found file, so read it
 583         { traceIf (ptext SLIT("readIFace") <+> text file_path)
 584         ; read_result <- readIface mod_name file_path hi_boot_file
 585         ; case read_result of
 586             Left err    -> returnM (Left (badIfaceFile file_path err))
 587             Right iface
 588                 | mi_module iface /= mod_name ->
 589                   return (Left (wrongIfaceModErr iface mod_name file_path))
 590                 | otherwise ->
 591                   returnM (Right iface{mi_package=pkg})
 592                         -- don't forget to fill in the package name...
 593         }}}
 594
 595 findHiFile :: DynFlags -> Bool -> Module -> IsBootInterface
 596            -> IO (Either FindResult (FilePath, IfacePackage))
 597 findHiFile dflags explicit mod_name hi_boot_file
 598  = do {
 599         -- In interactive or --make mode, we are *not allowed* to demand-load
 600         -- a home package .hi file.  So don't even look for them.
 601         -- This helps in the case where you are sitting in eg. ghc/lib/std
 602         -- and start up GHCi - it won't complain that all the modules it tries
 603         -- to load are found in the home location.
 604         ghci_mode <- readIORef v_GhcMode ;
 605         let { home_allowed = hi_boot_file ||
 606                              not (isCompManagerMode ghci_mode) } ;
 607         maybe_found <-  if home_allowed
 608                         then findModule dflags mod_name explicit
 609                         else findPackageModule dflags mod_name explicit;
 610
 611         case maybe_found of {
 612           Found loc pkg -> foundOk loc hi_boot_file pkg;
 613           err           -> return (Left err) ;
 614         }}
 615    where
 616     foundOk loc hi_boot_file pkg = do { -- Don't need module returned by finder
 617
 618         -- Return the path to M.hi, M.hi-boot, or M.hi-boot-n as appropriate
 619         let { hi_path            = ml_hi_file loc ;
 620               hi_boot_path       = replaceFilenameSuffix hi_path hiBootExt ;
 621               hi_boot_ver_path   = replaceFilenameSuffix hi_path hiBootVerExt
 622             };
 623
 624         if not hi_boot_file then
 625            return (Right (hi_path,pkg))
 626         else do {
 627                 hi_ver_exists <- doesFileExist hi_boot_ver_path ;
 628                 if hi_ver_exists then return (Right (hi_boot_ver_path,pkg))
 629                                  else return (Right (hi_boot_path,pkg))
 630         }}
 631 \end{code}
 632
 633 @readIface@ tries just the one file.
 634
 635 \begin{code}
 636 readIface :: Module -> String -> IsBootInterface
 637           -> IfM lcl (Either Message ModIface)
 638         -- Left err    <=> file not found, or unreadable, or illegible
 639         -- Right iface <=> successfully found and parsed
 640
 641 readIface wanted_mod_name file_path is_hi_boot_file
 642   = do  { dflags <- getDOpts
 643         ; ioToIOEnv (read_iface dflags wanted_mod_name file_path is_hi_boot_file) }
 644
 645 read_iface dflags wanted_mod file_path is_hi_boot_file
 646  | is_hi_boot_file              -- Read ascii
 647  = do { res <- tryMost (hGetStringBuffer file_path) ;
 648         case res of {
 649           Left exn     -> return (Left (text (showException exn))) ;
 650           Right buffer ->
 651         case unP parseIface (mkPState buffer loc dflags) of
 652           PFailed span err -> return (Left (mkLocMessage span err))
 653           POk _ iface
 654              | wanted_mod == actual_mod -> return (Right iface)
 655              | otherwise                -> return (Left err)
 656              where
 657                 actual_mod = mi_module iface
 658                 err = hiModuleNameMismatchWarn wanted_mod actual_mod
 659      }}
 660
 661  | otherwise            -- Read binary
 662  = do   { res <- tryMost (readBinIface file_path)
 663         ; case res of
 664             Right iface -> return (Right iface)
 665             Left exn    -> return (Left (text (showException exn))) }
 666  where
 667     loc  = mkSrcLoc (mkFastString file_path) 1 0
 668 \end{code}
 669
 670
 671 %*********************************************************
 672 %*                                                       *
 673         Wired-in interface for GHC.Prim
 674 %*                                                       *
 675 %*********************************************************
 676
 677 \begin{code}
 678 initExternalPackageState :: ExternalPackageState
 679 initExternalPackageState
 680   = EPS {
 681       eps_is_boot    = emptyModuleEnv,
 682       eps_PIT        = emptyPackageIfaceTable,
 683       eps_PTE        = emptyTypeEnv,
 684       eps_inst_env   = emptyInstEnv,
 685       eps_rule_base  = emptyRuleBase,
 686       eps_insts      = emptyNameEnv,
 687       eps_rules      = addRulesToPool [] (map mk_gated_rule builtinRules),
 688         -- Initialise the EPS rule pool with the built-in rules
 689       eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0
 690                            , n_insts_in = 0, n_insts_out = 0
 691                            , n_rules_in = length builtinRules, n_rules_out = 0 }
 692     }
 693   where
 694     mk_gated_rule (fn_name, core_rule)
 695         = ([fn_name], (nameModule fn_name, IfaceBuiltinRule (mkIfaceExtName fn_name) core_rule))
 696 \end{code}
 697
 698
 699 %*********************************************************
 700 %*                                                       *
 701         Wired-in interface for GHC.Prim
 702 %*                                                       *
 703 %*********************************************************
 704
 705 \begin{code}
 706 ghcPrimIface :: ModIface
 707 ghcPrimIface
 708   = (emptyModIface ThisPackage gHC_PRIM) {
 709         mi_exports  = [(gHC_PRIM, ghcPrimExports)],
 710         mi_decls    = [],
 711         mi_fixities = fixities,
 712         mi_fix_fn  = mkIfaceFixCache fixities
 713     }
 714   where
 715     fixities = [(getOccName seqId, Fixity 0 InfixR)]
 716                         -- seq is infixr 0
 717 \end{code}
 718
 719 %*********************************************************
 720 %*                                                      *
 721 \subsection{Statistics}
 722 %*                                                      *
 723 %*********************************************************
 724
 725 \begin{code}
 726 ifaceStats :: ExternalPackageState -> SDoc
 727 ifaceStats eps
 728   = hcat [text "Renamer stats: ", msg]
 729   where
 730     stats = eps_stats eps
 731     msg = vcat
 732         [int (n_ifaces_in stats) <+> text "interfaces read",
 733          hsep [ int (n_decls_out stats), text "type/class/variable imported, out of",
 734                 int (n_decls_in stats), text "read"],
 735          hsep [ int (n_insts_out stats), text "instance decls imported, out of",
 736                 int (n_insts_in stats), text "read"],
 737          hsep [ int (n_rules_out stats), text "rule decls imported, out of",
 738                 int (n_rules_in stats), text "read"]
 739         ]
 740 \end{code}
 741
 742
 743 %*********************************************************
 744 %*                                                       *
 745 \subsection{Errors}
 746 %*                                                       *
 747 %*********************************************************
 748
 749 \begin{code}
 750 badIfaceFile file err
 751   = vcat [ptext SLIT("Bad interface file:") <+> text file,
 752           nest 4 err]
 753
 754 hiModuleNameMismatchWarn :: Module -> Module -> Message
 755 hiModuleNameMismatchWarn requested_mod read_mod =
 756     hsep [ ptext SLIT("Something is amiss; requested module name")
 757          , ppr requested_mod
 758          , ptext SLIT("differs from name found in the interface file")
 759          , ppr read_mod
 760          ]
 761
 762 noIfaceErr dflags mod_name (PackageHidden pkg)
 763   = ptext SLIT("Could not import") <+> quotes (ppr mod_name) <> colon
 764     $$ ptext SLIT("it is a member of package") <+> quotes (ppr pkg) <> comma
 765          <+> ptext SLIT("which is hidden")
 766
 767 noIfaceErr dflags mod_name (ModuleHidden pkg)
 768   = ptext SLIT("Could not import") <+> quotes (ppr mod_name) <> colon
 769     $$ ptext SLIT("it is hidden")
 770         <+> parens (ptext SLIT("in package") <+> quotes (ppr pkg))
 771
 772 noIfaceErr dflags mod_name (NotFound files)
 773   = ptext SLIT("Could not find interface file for") <+> quotes (ppr mod_name)
 774     $$ extra files
 775   where
 776   extra files
 777     | verbosity dflags < 3 =
 778         text "(use -v to see a list of the files searched for)"
 779     | otherwise =
 780         hang (ptext SLIT("locations searched:")) 4 (vcat (map text files))
 781
 782 wrongIfaceModErr iface mod_name file_path
 783   = sep [ptext SLIT("Interface file") <+> iface_file,
 784          ptext SLIT("contains module") <+> quotes (ppr (mi_module iface)) <> comma,
 785          ptext SLIT("but we were expecting module") <+> quotes (ppr mod_name),
 786          sep [ptext SLIT("Probable cause: the source code which generated"),
 787              nest 2 iface_file,
 788              ptext SLIT("has an incompatible module name")
 789             ]
 790         ]
 791   where iface_file = doubleQuotes (text file_path)
 792 \end{code}