LoadIface.lhs 29.8 KB
Newer Older
Simon Marlow's avatar
Simon Marlow committed
1 2
%
% (c) The University of Glasgow 2006
3 4
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
Simon Marlow's avatar
Simon Marlow committed
5 6

Loading interface files
7 8 9

\begin{code}
module LoadIface (
Simon Marlow's avatar
Simon Marlow committed
10
	loadInterface, loadInterfaceForName, loadWiredInHomeIface, 
11
	loadSrcInterface, loadSysInterface, loadUserInterface, loadOrphanModules, 
12
	findAndReadIface, readIface,	-- Used when reading the module's old interface
13
	loadDecls,	-- Should move to TcIface and be renamed
14 15
	initExternalPackageState,

16
	ifaceStats, pprModIface, showIface
17 18 19 20
   ) where

#include "HsVersions.h"

21
import {-# SOURCE #-}	TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst, 
22
				 tcIfaceFamInst, tcIfaceVectInfo, tcIfaceAnnotations )
23

Simon Marlow's avatar
Simon Marlow committed
24
import DynFlags
25
import IfaceSyn
Simon Marlow's avatar
Simon Marlow committed
26 27 28 29
import IfaceEnv
import HscTypes

import BasicTypes hiding (SuccessFlag(..))
30
import TcRnMonad
Simon Marlow's avatar
Simon Marlow committed
31 32 33

import PrelNames
import PrelInfo
34
import MkId	( seqId )
Simon Marlow's avatar
Simon Marlow committed
35
import Rules
36
import Annotations
Simon Marlow's avatar
Simon Marlow committed
37 38 39
import InstEnv
import FamInstEnv
import Name
40
import NameEnv
Simon Marlow's avatar
Simon Marlow committed
41
import Module
Simon Marlow's avatar
Simon Marlow committed
42 43 44
import Maybes
import ErrUtils
import Finder
45
import UniqFM
Simon Marlow's avatar
Simon Marlow committed
46
import StaticFlags
47
import Outputable
Simon Marlow's avatar
Simon Marlow committed
48 49
import BinIface
import Panic
Ian Lynagh's avatar
Ian Lynagh committed
50
import Util
51
import FastString
52
import Fingerprint
Simon Marlow's avatar
Simon Marlow committed
53

Ian Lynagh's avatar
Ian Lynagh committed
54
import Control.Monad
55 56 57 58 59
\end{code}


%************************************************************************
%*									*
60
	loadSrcInterface, loadOrphanModules, loadHomeInterface
61

62
		These three are called from TcM-land	
63 64 65 66
%*									*
%************************************************************************

\begin{code}
Simon Marlow's avatar
Simon Marlow committed
67 68
-- | Load the interface corresponding to an @import@ directive in 
-- source code.  On a failure, fail in the monad with an error message.
69 70 71 72 73 74 75
loadSrcInterface :: SDoc
                 -> ModuleName
                 -> IsBootInterface     -- {-# SOURCE #-} ?
                 -> Maybe FastString    -- "package", if any
                 -> RnM ModIface

loadSrcInterface doc mod want_boot maybe_pkg  = do
Simon Marlow's avatar
Simon Marlow committed
76 77 78 79 80 81
  -- We must first find which Module this import refers to.  This involves
  -- calling the Finder, which as a side effect will search the filesystem
  -- and create a ModLocation.  If successful, loadIface will read the
  -- interface; it will call the Finder again, but the ModLocation will be
  -- cached from the first search.
  hsc_env <- getTopEnv
82
  res <- liftIO $ findImportedModule hsc_env mod maybe_pkg
Simon Marlow's avatar
Simon Marlow committed
83 84 85 86
  case res of
    Found _ mod -> do
      mb_iface <- initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)
      case mb_iface of
87
	Failed err      -> failWithTc err
Simon Marlow's avatar
Simon Marlow committed
88 89 90
	Succeeded iface -> return iface
    err ->
        let dflags = hsc_dflags hsc_env in
91
	failWithTc (cannotFindInterface dflags mod err)
92

Simon Marlow's avatar
Simon Marlow committed
93
-- | Load interfaces for a collection of orphan modules.
94 95 96 97
loadOrphanModules :: [Module]	      -- the modules
		  -> Bool	      -- these are family instance-modules
		  -> TcM ()
loadOrphanModules mods isFamInstMod
98
  | null mods = return ()
99 100 101
  | otherwise = initIfaceTcRn $
		do { traceIf (text "Loading orphan modules:" <+> 
		     		 fsep (map ppr mods))
102 103
		   ; mapM_ load mods
		   ; return () }
104 105
  where
    load mod   = loadSysInterface (mk_doc mod) mod
106
    mk_doc mod 
Ian Lynagh's avatar
Ian Lynagh committed
107 108
      | isFamInstMod = ppr mod <+> ptext (sLit "is a family-instance module")
      | otherwise    = ppr mod <+> ptext (sLit "is a orphan-instance module")
109

Simon Marlow's avatar
Simon Marlow committed
110 111 112
-- | Loads the interface for a given Name.
loadInterfaceForName :: SDoc -> Name -> TcRn ModIface
loadInterfaceForName doc name
Ian Lynagh's avatar
Ian Lynagh committed
113 114 115 116 117 118
  = do { 
    when debugIsOn $ do
        -- Should not be called with a name from the module being compiled
        { this_mod <- getModule
        ; MASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc )
        }
119 120
  ; ASSERT2( isExternalName name, ppr name ) 
    initIfaceTcRn $ loadSysInterface doc (nameModule name)
Ian Lynagh's avatar
Ian Lynagh committed
121
  }
122

Simon Marlow's avatar
Simon Marlow committed
123
-- | An 'IfM' function to load the home interface for a wired-in thing,
124
-- so that we're sure that we see its instance declarations and rules
125
-- See Note [Loading instances for wired-in things] in TcIface
Simon Marlow's avatar
Simon Marlow committed
126
loadWiredInHomeIface :: Name -> IfM lcl ()
127 128
loadWiredInHomeIface name
  = ASSERT( isWiredInName name )
129
    do _ <- loadSysInterface doc (nameModule name); return ()
130
  where
Ian Lynagh's avatar
Ian Lynagh committed
131
    doc = ptext (sLit "Need home interface for wired-in thing") <+> ppr name
132

133
-- | Loads a system interface and throws an exception if it fails
134
loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
135 136 137 138 139 140 141 142 143 144 145
loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBySystem

-- | Loads a user interface and throws an exception if it fails. The first parameter indicates
-- whether we should import the boot variant of the module
loadUserInterface :: Bool -> SDoc -> Module -> IfM lcl ModIface
loadUserInterface is_boot doc mod_name = loadInterfaceWithException doc mod_name (ImportByUser is_boot)

-- | A wrapper for 'loadInterface' that throws an exception if it fails
loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface
loadInterfaceWithException doc mod_name where_from
  = do	{ mb_iface <- loadInterface doc mod_name where_from
146
	; case mb_iface of 
147 148
	    Failed err      -> ghcError (ProgramError (showSDoc err))
	    Succeeded iface -> return iface }
149 150 151 152 153 154 155 156 157 158 159 160 161 162
\end{code}


%*********************************************************
%*							*
		loadInterface

	The main function to load an interface
	for an imported module, and put it in
	the External Package State
%*							*
%*********************************************************

\begin{code}
Simon Marlow's avatar
Simon Marlow committed
163
loadInterface :: SDoc -> Module -> WhereFrom
164
	      -> IfM lcl (MaybeErr Message ModIface)
165

166 167 168
-- loadInterface looks in both the HPT and PIT for the required interface
-- If not found, it loads it, and puts it in the PIT (always). 

169 170 171 172 173 174 175
-- If it can't find a suitable interface file, we
--	a) modify the PackageIfaceTable to have an empty entry
--		(to avoid repeated complaints)
--	b) return (Left message)
--
-- It's not necessarily an error for there not to be an interface
-- file -- perhaps the module has changed, and that interface 
176
-- is no longer used
177

178
loadInterface doc_str mod from
179
  = do	{ 	-- Read the state
180
	  (eps,hpt) <- getEpsAndHpt
181

182
	; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from)
183

184
		-- Check whether we have the interface already
Simon Marlow's avatar
Simon Marlow committed
185 186
 	; dflags <- getDOpts
	; case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of {
187
	    Just iface 
188
		-> return (Succeeded iface) ;	-- Already loaded
189 190
			-- The (src_imp == mi_boot iface) test checks that the already-loaded
			-- interface isn't a boot iface.  This can conceivably happen,
191
			-- if an earlier import had a before we got to real imports.   I think.
Ian Lynagh's avatar
Ian Lynagh committed
192
	    _ -> do {
193 194

	-- READ THE MODULE IN
195 196 197
	; read_result <- case (wantHiBootFile dflags eps mod from) of
                           Failed err             -> return (Failed err)
                           Succeeded hi_boot_file -> findAndReadIface doc_str mod hi_boot_file
198
	; case read_result of {
199
	    Failed err -> do
Simon Marlow's avatar
Simon Marlow committed
200
	  	{ let fake_iface = emptyModIface mod
201 202 203 204

		; updateEps_ $ \eps ->
			eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface }
			-- Not found, so add an empty iface to 
205
			-- the EPS map so that we don't look again
206
				
207
		; return (Failed err) } ;
208 209

	-- Found and parsed!
210 211 212 213 214 215 216 217 218
	-- We used to have a sanity check here that looked for:
	--  * System importing ..
	--  * a home package module ..
	--  * that we know nothing about (mb_dep == Nothing)!
	--
	-- But this is no longer valid because thNameToGhcName allows users to
	-- cause the system to load arbitrary interfaces (by supplying an appropriate
	-- Template Haskell original-name).
	    Succeeded (iface, file_path) ->
219

220
	let 
221
	    loc_doc = text file_path
222 223
	in 
	initIfaceLcl mod loc_doc $ do
224 225 226 227 228 229 230 231 232

	-- 	Load the new ModIface into the External Package State
	-- Even home-package interfaces loaded by loadInterface 
	-- 	(which only happens in OneShot mode; in Batch/Interactive 
	--  	mode, home-package modules are loaded one by one into the HPT)
	-- are put in the EPS.
	--
	-- The main thing is to add the ModIface to the PIT, but
	-- we also take the
233
	--	IfaceDecls, IfaceInst, IfaceFamInst, IfaceRules, IfaceVectInfo
234 235 236 237 238 239 240
	-- out of the ModIface and put them into the big EPS pools

	-- NB: *first* we do loadDecl, so that the provenance of all the locally-defined
	---    names is done correctly (notably, whether this is an .hi file or .hi-boot file).
	--     If we do loadExport first the wrong info gets into the cache (unless we
	-- 	explicitly tag each export which seems a bit of a bore)

241 242
	; ignore_prags      <- doptM Opt_IgnoreInterfacePragmas
	; new_eps_decls     <- loadDecls ignore_prags (mi_decls iface)
243
	; new_eps_insts     <- mapM tcIfaceInst (mi_insts iface)
244 245
	; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
	; new_eps_rules     <- tcIfaceRules ignore_prags (mi_rules iface)
246
	; new_eps_anns      <- tcIfaceAnnotations (mi_anns iface)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
247 248
        ; new_eps_vect_info <- tcIfaceVectInfo mod (mkNameEnv new_eps_decls) 
                                               (mi_vect_info iface)
249

250 251 252 253
	; let {	final_iface = iface {	
			        mi_decls     = panic "No mi_decls in PIT",
				mi_insts     = panic "No mi_insts in PIT",
				mi_fam_insts = panic "No mi_fam_insts in PIT",
254 255
				mi_rules     = panic "No mi_rules in PIT",
				mi_anns      = panic "No mi_anns in PIT"
256 257
                              }
               }
258 259

	; updateEps_  $ \ eps -> 
260
           if elemModuleEnv mod (eps_PIT eps) then eps else
261 262 263 264 265 266 267 268 269
	    eps { 
	      eps_PIT          = extendModuleEnv (eps_PIT eps) mod final_iface,
	      eps_PTE          = addDeclsToPTE   (eps_PTE eps) new_eps_decls,
	      eps_rule_base    = extendRuleBaseList (eps_rule_base eps) 
						    new_eps_rules,
	      eps_inst_env     = extendInstEnvList (eps_inst_env eps)  
						   new_eps_insts,
	      eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps)
						      new_eps_fam_insts,
270 271
              eps_vect_info    = plusVectInfo (eps_vect_info eps) 
                                              new_eps_vect_info,
272 273
              eps_ann_env      = extendAnnEnvList (eps_ann_env eps)
                                                  new_eps_anns,
274 275 276 277 278 279 280 281 282
              eps_mod_fam_inst_env
			       = let
				   fam_inst_env = 
				     extendFamInstEnvList emptyFamInstEnv
							  new_eps_fam_insts
				 in
				 extendModuleEnv (eps_mod_fam_inst_env eps)
						 mod
						 fam_inst_env,
283 284
	      eps_stats        = addEpsInStats (eps_stats eps) 
					       (length new_eps_decls)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
285 286
					       (length new_eps_insts)
					       (length new_eps_rules) }
287

288 289 290
	; return (Succeeded final_iface)
    }}}}

291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322
wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom
	       -> MaybeErr Message IsBootInterface
-- Figure out whether we want Foo.hi or Foo.hi-boot
wantHiBootFile dflags eps mod from
  = case from of
       ImportByUser usr_boot 
          | usr_boot && not this_package
          -> Failed (badSourceImport mod)
          | otherwise -> Succeeded usr_boot

       ImportBySystem
          | not this_package   -- If the module to be imported is not from this package
          -> Succeeded False   -- don't look it up in eps_is_boot, because that is keyed
                               -- on the ModuleName of *home-package* modules only. 
                               -- We never import boot modules from other packages!

          | otherwise
          -> case lookupUFM (eps_is_boot eps) (moduleName mod) of
		Just (_, is_boot) -> Succeeded is_boot
                Nothing	          -> Succeeded False
		     -- The boot-ness of the requested interface, 
	      	     -- based on the dependencies in directly-imported modules
  where
    this_package = thisPackage dflags == modulePackageId mod

badSourceImport :: Module -> SDoc
badSourceImport mod
  = hang (ptext (sLit "You cannot {-# SOURCE #-} import a module from another package"))
       2 (ptext (sLit "but") <+> quotes (ppr mod) <+> ptext (sLit "is from package")
          <+> quotes (ppr (modulePackageId mod)))
\end{code}

323 324 325 326
{-
Used to be used for the loadInterface sanity check on system imports. That has been removed, but I'm leaving this in pending
review of this decision by SPJ - MCB 10/2008

Ian Lynagh's avatar
Ian Lynagh committed
327
badDepMsg :: Module -> SDoc
328
badDepMsg mod 
Ian Lynagh's avatar
Ian Lynagh committed
329 330 331
  = hang (ptext (sLit "Interface file inconsistency:"))
       2 (sep [ptext (sLit "home-package module") <+> quotes (ppr mod) <+> ptext (sLit "is needed,"), 
	       ptext (sLit "but is not listed in the dependencies of the interfaces directly imported by the module being compiled")])
332
-}
333

334
\begin{code}
335 336 337 338 339 340 341
-----------------------------------------------------
--	Loading type/class/value decls
-- We pass the full Module name here, replete with
-- its package info, so that we can build a Name for
-- each binder with the right package info in it
-- All subsequent lookups, including crucially lookups during typechecking
-- the declaration itself, will find the fully-glorious Name
342 343 344 345
--
-- We handle ATs specially.  They are not main declarations, but also not
-- implict things (in particular, adding them to `implicitTyThings' would mess
-- things up in the renaming/type checking of source programs).
346 347
-----------------------------------------------------

348 349 350 351
addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv
addDeclsToPTE pte things = extendNameEnvList pte things

loadDecls :: Bool
352
	  -> [(Fingerprint, IfaceDecl)]
353 354 355 356 357 358
	  -> IfL [(Name,TyThing)]
loadDecls ignore_prags ver_decls
   = do { mod <- getIfModule
 	; thingss <- mapM (loadDecl ignore_prags mod) ver_decls
	; return (concat thingss)
	}
359

360
loadDecl :: Bool		    -- Don't load pragmas into the decl pool
361
	 -> Module
362
	  -> (Fingerprint, IfaceDecl)
363 364
	  -> IfL [(Name,TyThing)]   -- The list can be poked eagerly, but the
				    -- TyThings are forkM'd thunks
365
loadDecl ignore_prags mod (_version, decl)
366 367
  = do 	{ 	-- Populate the name cache with final versions of all 
		-- the names associated with the decl
368
	  main_name      <- lookupOrig mod (ifName decl)
369
--        ; traceIf (text "Loading decl for " <> ppr main_name)
370
	; implicit_names <- mapM (lookupOrig mod) (ifaceDeclSubBndrs decl)
371 372

	-- Typecheck the thing, lazily
373
	-- NB. Firstly, the laziness is there in case we never need the
374 375 376 377
	-- declaration (in one-shot mode), and secondly it is there so that 
	-- we don't look up the occurrence of a name before calling mk_new_bndr
	-- on the binder.  This is important because we must get the right name
	-- which includes its nameParent.
378 379 380 381

	; thing <- forkM doc $ do { bumpDeclStats main_name
				  ; tcIfaceDecl ignore_prags decl }

382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435
        -- Populate the type environment with the implicitTyThings too.
        -- 
        -- Note [Tricky iface loop]
        -- ~~~~~~~~~~~~~~~~~~~~~~~~
        -- Summary: The delicate point here is that 'mini-env' must be
        -- buildable from 'thing' without demanding any of the things
        -- 'forkM'd by tcIfaceDecl.
        --
        -- In more detail: Consider the example
        -- 	data T a = MkT { x :: T a }
        -- The implicitTyThings of T are:  [ <datacon MkT>, <selector x>]
        -- (plus their workers, wrappers, coercions etc etc)
        -- 
        -- We want to return an environment 
        --	[ "MkT" -> <datacon MkT>, "x" -> <selector x>, ... ]
        -- (where the "MkT" is the *Name* associated with MkT, etc.)
        --
        -- We do this by mapping the implict_names to the associated
        -- TyThings.  By the invariant on ifaceDeclSubBndrs and
        -- implicitTyThings, we can use getOccName on the implicit
        -- TyThings to make this association: each Name's OccName should
        -- be the OccName of exactly one implictTyThing.  So the key is
        -- to define a "mini-env"
        --
        -- [ 'MkT' -> <datacon MkT>, 'x' -> <selector x>, ... ]
        -- where the 'MkT' here is the *OccName* associated with MkT.
        --
        -- However, there is a subtlety: due to how type checking needs
        -- to be staged, we can't poke on the forkM'd thunks inside the
        -- implictTyThings while building this mini-env.  
        -- If we poke these thunks too early, two problems could happen:
        --    (1) When processing mutually recursive modules across
        --        hs-boot boundaries, poking too early will do the
        --        type-checking before the recursive knot has been tied,
        --        so things will be type-checked in the wrong
        --        environment, and necessary variables won't be in
        --        scope.
        --        
        --    (2) Looking up one OccName in the mini_env will cause
        --        others to be looked up, which might cause that
        --        original one to be looked up again, and hence loop.
        --
        -- The code below works because of the following invariant:
        -- getOccName on a TyThing does not force the suspended type
        -- checks in order to extract the name. For example, we don't
        -- poke on the "T a" type of <selector x> on the way to
        -- extracting <selector x>'s OccName. Of course, there is no
        -- reason in principle why getting the OccName should force the
        -- thunks, but this means we need to be careful in
        -- implicitTyThings and its helper functions.
        --
        -- All a bit too finely-balanced for my liking.

        -- This mini-env and lookup function mediates between the
Thomas Schilling's avatar
Thomas Schilling committed
436
        --'Name's n and the map from 'OccName's to the implicit TyThings
437 438 439
	; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]
	      lookup n = case lookupOccEnv mini_env (getOccName n) of
			   Just thing -> thing
440
			   Nothing    -> 
441
			     pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl))
442

443
	; return $ (main_name, thing) :
444 445 446
                      -- uses the invariant that implicit_names and
                      -- implictTyThings are bijective
                      [(n, lookup n) | n <- implicit_names]
447
	}
448
  where
Ian Lynagh's avatar
Ian Lynagh committed
449
    doc = ptext (sLit "Declaration for") <+> ppr (ifName decl)
450

451 452 453 454 455 456
bumpDeclStats :: Name -> IfL ()		-- Record that one more declaration has actually been used
bumpDeclStats name
  = do	{ traceIf (text "Loading decl for" <+> ppr name)
	; updateEps_ (\eps -> let stats = eps_stats eps
			      in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })
	}
457 458 459 460 461 462 463 464 465 466
\end{code}


%*********************************************************
%*							*
\subsection{Reading an interface file}
%*							*
%*********************************************************

\begin{code}
Simon Marlow's avatar
Simon Marlow committed
467
findAndReadIface :: SDoc -> Module
468 469
		 -> IsBootInterface	-- True  <=> Look for a .hi-boot file
					-- False <=> Look for .hi file
470
		 -> TcRnIf gbl lcl (MaybeErr Message (ModIface, FilePath))
471 472 473 474 475 476
	-- Nothing <=> file not found, or unreadable, or illegible
	-- Just x  <=> successfully found and parsed 

	-- It *doesn't* add an error to the monad, because 
	-- sometimes it's ok to fail... see notes with loadInterface

Simon Marlow's avatar
Simon Marlow committed
477
findAndReadIface doc_str mod hi_boot_file
Ian Lynagh's avatar
Ian Lynagh committed
478
  = do	{ traceIf (sep [hsep [ptext (sLit "Reading"), 
479
			      if hi_boot_file 
Ian Lynagh's avatar
Ian Lynagh committed
480
				then ptext (sLit "[boot]") 
481
				else empty,
Ian Lynagh's avatar
Ian Lynagh committed
482
			      ptext (sLit "interface for"), 
Simon Marlow's avatar
Simon Marlow committed
483
			      ppr mod <> semi],
Ian Lynagh's avatar
Ian Lynagh committed
484
		        nest 4 (ptext (sLit "reason:") <+> doc_str)])
485 486

	-- Check for GHC.Prim, and return its static interface
487
	; dflags <- getDOpts
Simon Marlow's avatar
Simon Marlow committed
488
	; if mod == gHC_PRIM
489
	  then return (Succeeded (ghcPrimIface,
Simon Marlow's avatar
Simon Marlow committed
490
				   "<built in interface for GHC.Prim>"))
491 492 493
	  else do

	-- Look for the file
494
	; hsc_env <- getTopEnv
495
	; mb_found <- liftIO (findExactModule hsc_env mod)
496
	; case mb_found of {
Simon Marlow's avatar
Simon Marlow committed
497 498
              
	      Found loc mod -> do 
499 500

	-- Found file, so read it
Simon Marlow's avatar
Simon Marlow committed
501 502
	{ let { file_path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) }

503 504 505
        -- If the interface is in the current package then if we could
        -- load it would already be in the HPT and we assume that our
        -- callers checked that.
Simon Marlow's avatar
Simon Marlow committed
506 507
        ; if thisPackage dflags == modulePackageId mod
                && not (isOneShot (ghcMode dflags))
508
            then return (Failed (homeModError mod loc))
Simon Marlow's avatar
Simon Marlow committed
509 510
            else do {

Ian Lynagh's avatar
Ian Lynagh committed
511
        ; traceIf (ptext (sLit "readIFace") <+> text file_path)
Simon Marlow's avatar
Simon Marlow committed
512
	; read_result <- readIface mod file_path hi_boot_file
513
	; case read_result of
514
	    Failed err -> return (Failed (badIfaceFile file_path err))
515
	    Succeeded iface 
Simon Marlow's avatar
Simon Marlow committed
516 517
		| mi_module iface /= mod ->
		  return (Failed (wrongIfaceModErr iface mod file_path))
518
		| otherwise ->
519
		  return (Succeeded (iface, file_path))
520
			-- Don't forget to fill in the package name...
Ian Lynagh's avatar
Ian Lynagh committed
521 522 523 524 525 526 527 528
	}}
	    ; err -> do
		{ traceIf (ptext (sLit "...not found"))
		; dflags <- getDOpts
		; return (Failed (cannotFindInterface dflags 
					(moduleName mod) err)) }
        }
        }
529 530 531 532 533
\end{code}

@readIface@ tries just the one file.

\begin{code}
Simon Marlow's avatar
Simon Marlow committed
534
readIface :: Module -> FilePath -> IsBootInterface 
535
	  -> TcRnIf gbl lcl (MaybeErr Message ModIface)
536 537
	-- Failed err    <=> file not found, or unreadable, or illegible
	-- Succeeded iface <=> successfully found and parsed 
538

Ian Lynagh's avatar
Ian Lynagh committed
539 540
readIface wanted_mod file_path _
  = do	{ res <- tryMostM $
541
                 readBinIface CheckHiWay QuietBinIFaceReading file_path
542
	; case res of
543 544 545 546 547 548 549 550
	    Right iface 
		| wanted_mod == actual_mod -> return (Succeeded iface)
		| otherwise	  	   -> return (Failed err)
		where
		  actual_mod = mi_module iface
		  err = hiModuleNameMismatchWarn wanted_mod actual_mod

	    Left exn    -> return (Failed (text (showException exn)))
551
    }
552 553 554 555 556 557 558 559 560 561 562 563 564
\end{code}


%*********************************************************
%*						 	 *
	Wired-in interface for GHC.Prim
%*							 *
%*********************************************************

\begin{code}
initExternalPackageState :: ExternalPackageState
initExternalPackageState
  = EPS { 
565 566 567 568 569 570
      eps_is_boot      = emptyUFM,
      eps_PIT          = emptyPackageIfaceTable,
      eps_PTE          = emptyTypeEnv,
      eps_inst_env     = emptyInstEnv,
      eps_fam_inst_env = emptyFamInstEnv,
      eps_rule_base    = mkRuleBase builtinRules,
571
	-- Initialise the EPS rule pool with the built-in rules
572 573
      eps_mod_fam_inst_env
                       = emptyModuleEnv,
574
      eps_vect_info    = noVectInfo,
575
      eps_ann_env      = emptyAnnEnv,
576 577 578
      eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0
			   , n_insts_in = 0, n_insts_out = 0
			   , n_rules_in = length builtinRules, n_rules_out = 0 }
579 580 581 582 583 584 585 586 587 588 589 590 591
    }
\end{code}


%*********************************************************
%*						 	 *
	Wired-in interface for GHC.Prim
%*							 *
%*********************************************************

\begin{code}
ghcPrimIface :: ModIface
ghcPrimIface
Simon Marlow's avatar
Simon Marlow committed
592
  = (emptyModIface gHC_PRIM) {
593
	mi_exports  = [(gHC_PRIM, ghcPrimExports)],
594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611
	mi_decls    = [],
	mi_fixities = fixities,
	mi_fix_fn  = mkIfaceFixCache fixities
    }		
  where
    fixities = [(getOccName seqId, Fixity 0 InfixR)]
			-- seq is infixr 0
\end{code}

%*********************************************************
%*							*
\subsection{Statistics}
%*							*
%*********************************************************

\begin{code}
ifaceStats :: ExternalPackageState -> SDoc
ifaceStats eps 
612
  = hcat [text "Renamer stats: ", msg]
613
  where
614 615 616 617 618 619 620 621 622
    stats = eps_stats eps
    msg = vcat 
    	[int (n_ifaces_in stats) <+> text "interfaces read",
    	 hsep [ int (n_decls_out stats), text "type/class/variable imported, out of", 
    	        int (n_decls_in stats), text "read"],
    	 hsep [ int (n_insts_out stats), text "instance decls imported, out of",  
    	        int (n_insts_in stats), text "read"],
    	 hsep [ int (n_rules_out stats), text "rule decls imported, out of",  
    	        int (n_rules_in stats), text "read"]
623
	]
SamB's avatar
SamB committed
624
\end{code}
625 626


627 628 629 630 631 632 633
%************************************************************************
%*				 					*
		Printing interfaces
%*				 					*
%************************************************************************

\begin{code}
634 635 636
-- | Read binary interface, and print it out
showIface :: HscEnv -> FilePath -> IO ()
showIface hsc_env filename = do
Ian Lynagh's avatar
Ian Lynagh committed
637
   -- skip the hi way check; we don't want to worry about profiled vs.
638
   -- non-profiled interfaces, for example.
639 640
   iface <- initTcRnIf 's' hsc_env () () $
       readBinIface IgnoreHiWay TraceBinIFaceReading filename
641 642 643 644 645 646 647
   printDump (pprModIface iface)
\end{code}

\begin{code}
pprModIface :: ModIface -> SDoc
-- Show a ModIface
pprModIface iface
Ian Lynagh's avatar
Ian Lynagh committed
648
 = vcat [ ptext (sLit "interface")
649
		<+> ppr (mi_module iface) <+> pp_boot
Ian Lynagh's avatar
Ian Lynagh committed
650 651 652
		<+> (if mi_orphan iface then ptext (sLit "[orphan module]") else empty)
		<+> (if mi_finsts iface then ptext (sLit "[family instance module]") else empty)
		<+> (if mi_hpc    iface then ptext (sLit "[hpc]") else empty)
653
		<+> integer opt_HiVersion
654 655 656 657 658
        , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash iface))
        , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface))
        , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface))
        , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface))
        , nest 2 (ptext (sLit "where"))
659 660 661
	, vcat (map pprExport (mi_exports iface))
	, pprDeps (mi_deps iface)
	, vcat (map pprUsage (mi_usages iface))
662
	, vcat (map pprIfaceAnnotation (mi_anns iface))
663 664 665
	, pprFixities (mi_fixities iface)
	, vcat (map pprIfaceDecl (mi_decls iface))
	, vcat (map ppr (mi_insts iface))
666
	, vcat (map ppr (mi_fam_insts iface))
667
	, vcat (map ppr (mi_rules iface))
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
668
        , pprVectInfo (mi_vect_info iface)
669
        , pprVectInfo (mi_vect_info iface)
Ian Lynagh's avatar
Ian Lynagh committed
670
	, ppr (mi_warns iface)
671
	, pprTrustInfo (mi_trust iface)
672
 	]
673
  where
Ian Lynagh's avatar
Ian Lynagh committed
674
    pp_boot | mi_boot iface = ptext (sLit "[boot]")
675 676 677 678 679 680 681 682 683 684 685
	    | otherwise     = empty
\end{code}

When printing export lists, we print like this:
	Avail   f		f
	AvailTC C [C, x, y]	C(x,y)
	AvailTC C [x, y]	C!(x,y)		-- Exporting x, y but not C

\begin{code}
pprExport :: IfaceExport -> SDoc
pprExport (mod, items)
Ian Lynagh's avatar
Ian Lynagh committed
686
 = hsep [ ptext (sLit "export"), ppr mod, hsep (map pp_avail items) ]
687 688 689 690 691 692 693 694 695 696 697 698
  where
    pp_avail :: GenAvailInfo OccName -> SDoc
    pp_avail (Avail occ)    = ppr occ
    pp_avail (AvailTC _ []) = empty
    pp_avail (AvailTC n (n':ns)) 
	| n==n'     = ppr n <> pp_export ns
 	| otherwise = ppr n <> char '|' <> pp_export (n':ns)
    
    pp_export []    = empty
    pp_export names = braces (hsep (map ppr names))

pprUsage :: Usage -> SDoc
699
pprUsage usage@UsagePackageModule{}
700
  = pprUsageImport usage usg_mod
701
pprUsage usage@UsageHomeModule{}
702
  = pprUsageImport usage usg_mod_name $$
703 704 705 706
    nest 2 (
	maybe empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$
        vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]
        )
707

708 709 710 711 712 713 714 715
pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc
pprUsageImport usage usg_mod'
  = hsep [ptext (sLit "import"), safe, ppr (usg_mod' usage),
                       ppr (usg_mod_hash usage)]
    where
        safe | usg_safe usage = ptext $ sLit "safe"
             | otherwise      = ptext $ sLit " -/ "

716
pprDeps :: Dependencies -> SDoc
717 718
pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,
		dep_finsts = finsts })
Ian Lynagh's avatar
Ian Lynagh committed
719
  = vcat [ptext (sLit "module dependencies:") <+> fsep (map ppr_mod mods),
720
	  ptext (sLit "package dependencies:") <+> fsep (map ppr_pkg pkgs),
Ian Lynagh's avatar
Ian Lynagh committed
721 722
	  ptext (sLit "orphans:") <+> fsep (map ppr orphs),
	  ptext (sLit "family instance modules:") <+> fsep (map ppr finsts)
723 724 725
	]
  where
    ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot
726 727
    ppr_pkg (pkg,trust_req)  = ppr pkg <>
                               (if trust_req then text "*" else empty)
728 729 730
    ppr_boot True  = text "[boot]"
    ppr_boot False = empty

731
pprIfaceDecl :: (Fingerprint, IfaceDecl) -> SDoc
732
pprIfaceDecl (ver, decl)
733
  = ppr ver $$ nest 2 (ppr decl)
734 735 736

pprFixities :: [(OccName, Fixity)] -> SDoc
pprFixities []    = empty
Ian Lynagh's avatar
Ian Lynagh committed
737
pprFixities fixes = ptext (sLit "fixities") <+> pprWithCommas pprFix fixes
738 739 740
		  where
		    pprFix (occ,fix) = ppr fix <+> ppr occ 

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
741
pprVectInfo :: IfaceVectInfo -> SDoc
742 743 744 745 746
pprVectInfo (IfaceVectInfo { ifaceVectInfoVar          = vars
                           , ifaceVectInfoTyCon        = tycons
                           , ifaceVectInfoTyConReuse   = tyconsReuse
                           , ifaceVectInfoScalarVars   = scalarVars
                           , ifaceVectInfoScalarTyCons = scalarTyCons
747 748
                           }) = 
  vcat 
Ian Lynagh's avatar
Ian Lynagh committed
749 750 751
  [ ptext (sLit "vectorised variables:") <+> hsep (map ppr vars)
  , ptext (sLit "vectorised tycons:") <+> hsep (map ppr tycons)
  , ptext (sLit "vectorised reused tycons:") <+> hsep (map ppr tyconsReuse)
752 753
  , ptext (sLit "scalar variables:") <+> hsep (map ppr scalarVars)
  , ptext (sLit "scalar tycons:") <+> hsep (map ppr scalarTyCons)
754
  ]
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
755

756 757 758
pprTrustInfo :: IfaceTrustInfo -> SDoc
pprTrustInfo trust = ptext (sLit "trusted:") <+> ppr trust

Ian Lynagh's avatar
Ian Lynagh committed
759 760 761 762 763 764 765 766 767
instance Outputable Warnings where
    ppr = pprWarns

pprWarns :: Warnings -> SDoc
pprWarns NoWarnings	    = empty
pprWarns (WarnAll txt)  = ptext (sLit "Warn all") <+> ppr txt
pprWarns (WarnSome prs) = ptext (sLit "Warnings")
                        <+> vcat (map pprWarning prs)
    where pprWarning (name, txt) = ppr name <+> ppr txt
768 769 770 771

pprIfaceAnnotation :: IfaceAnnotation -> SDoc
pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized })
  = ppr target <+> ptext (sLit "annotated by") <+> ppr serialized
772 773 774
\end{code}


775 776 777 778 779 780 781
%*********************************************************
%*						 	 *
\subsection{Errors}
%*							 *
%*********************************************************

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
782
badIfaceFile :: String -> SDoc -> SDoc
783
badIfaceFile file err
Ian Lynagh's avatar
Ian Lynagh committed
784
  = vcat [ptext (sLit "Bad interface file:") <+> text file, 
785 786
	  nest 4 err]

787
hiModuleNameMismatchWarn :: Module -> Module -> Message
788
hiModuleNameMismatchWarn requested_mod read_mod = 
Simon Marlow's avatar
Simon Marlow committed
789 790 791
  withPprStyle defaultUserStyle $
    -- we want the Modules below to be qualified with package names,
    -- so reset the PrintUnqualified setting.
Ian Lynagh's avatar
Ian Lynagh committed
792
    hsep [ ptext (sLit "Something is amiss; requested module ")
793
	 , ppr requested_mod
Ian Lynagh's avatar
Ian Lynagh committed
794
	 , ptext (sLit "differs from name found in the interface file")
795 796 797
   	 , ppr read_mod
  	 ]

Ian Lynagh's avatar
Ian Lynagh committed
798
wrongIfaceModErr :: ModIface -> Module -> String -> SDoc
799
wrongIfaceModErr iface mod_name file_path 
Ian Lynagh's avatar
Ian Lynagh committed
800 801 802 803
  = sep [ptext (sLit "Interface file") <+> iface_file,
         ptext (sLit "contains module") <+> quotes (ppr (mi_module iface)) <> comma,
         ptext (sLit "but we were expecting module") <+> quotes (ppr mod_name),
	 sep [ptext (sLit "Probable cause: the source code which generated"),
804
	     nest 2 iface_file,
Ian Lynagh's avatar
Ian Lynagh committed
805
	     ptext (sLit "has an incompatible module name")
806 807 808
	    ]
	]
  where iface_file = doubleQuotes (text file_path)
Simon Marlow's avatar
Simon Marlow committed
809

Ian Lynagh's avatar
Ian Lynagh committed
810
homeModError :: Module -> ModLocation -> SDoc
Simon Marlow's avatar
Simon Marlow committed
811
homeModError mod location
Ian Lynagh's avatar
Ian Lynagh committed
812
  = ptext (sLit "attempting to use module ") <> quotes (ppr mod)
Simon Marlow's avatar
Simon Marlow committed
813 814 815
    <> (case ml_hs_file location of
           Just file -> space <> parens (text file)
           Nothing   -> empty)
Ian Lynagh's avatar
Ian Lynagh committed
816
    <+> ptext (sLit "which is not loaded")
817
\end{code}
818