LoadIface.lhs 26.9 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, 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, 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
22
				 tcIfaceFamInst, tcIfaceVectInfo )
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 34 35 36 37 38 39
import Type

import PrelNames
import PrelInfo
import PrelRules
import Rules
import InstEnv
import FamInstEnv
import Name
40
import NameEnv
Simon Marlow's avatar
Simon Marlow committed
41
import MkId
Simon Marlow's avatar
Simon Marlow committed
42
import Module
Simon Marlow's avatar
Simon Marlow committed
43 44 45 46
import OccName
import Maybes
import ErrUtils
import Finder
47
import LazyUniqFM
Simon Marlow's avatar
Simon Marlow committed
48
import StaticFlags
49
import Outputable
Simon Marlow's avatar
Simon Marlow committed
50 51
import BinIface
import Panic
Ian Lynagh's avatar
Ian Lynagh committed
52
import Util
53
import FastString
54
import Fingerprint
Simon Marlow's avatar
Simon Marlow committed
55

Ian Lynagh's avatar
Ian Lynagh committed
56
import Control.Monad
Simon Marlow's avatar
Simon Marlow committed
57 58
import Data.List
import Data.Maybe
59 60 61 62 63
\end{code}


%************************************************************************
%*									*
64
	loadSrcInterface, loadOrphanModules, loadHomeInterface
65

66
		These three are called from TcM-land	
67 68 69 70
%*									*
%************************************************************************

\begin{code}
Simon Marlow's avatar
Simon Marlow committed
71 72 73 74 75 76 77 78 79 80
-- | Load the interface corresponding to an @import@ directive in 
-- source code.  On a failure, fail in the monad with an error message.
loadSrcInterface :: SDoc -> ModuleName -> IsBootInterface -> RnM ModIface
loadSrcInterface doc mod want_boot  = do 	
  -- 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
81
  res <- liftIO $ findImportedModule hsc_env mod Nothing
Simon Marlow's avatar
Simon Marlow committed
82 83 84 85
  case res of
    Found _ mod -> do
      mb_iface <- initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)
      case mb_iface of
86
	Failed err      -> failWithTc err
Simon Marlow's avatar
Simon Marlow committed
87 88 89
	Succeeded iface -> return iface
    err ->
        let dflags = hsc_dflags hsc_env in
90
	failWithTc (cannotFindInterface dflags mod err)
91

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

Simon Marlow's avatar
Simon Marlow committed
109 110 111
-- | Loads the interface for a given Name.
loadInterfaceForName :: SDoc -> Name -> TcRn ModIface
loadInterfaceForName doc name
Ian Lynagh's avatar
Ian Lynagh committed
112 113 114 115 116 117 118 119
  = 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 )
        }
  ; initIfaceTcRn $ loadSysInterface doc (nameModule name)
  }
120

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

Simon Marlow's avatar
Simon Marlow committed
131
-- | A wrapper for 'loadInterface' that throws an exception if it fails
132
loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
133 134 135
loadSysInterface doc mod_name
  = do	{ mb_iface <- loadInterface doc mod_name ImportBySystem
	; case mb_iface of 
136 137
	    Failed err      -> ghcError (ProgramError (showSDoc err))
	    Succeeded iface -> return iface }
138 139
\end{code}

140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160
Note [Loading instances]
~~~~~~~~~~~~~~~~~~~~~~~~
We need to make sure that we have at least *read* the interface files
for any module with an instance decl or RULE that we might want.  

* If the instance decl is an orphan, we have a whole separate mechanism
  (loadOprhanModules)

* If the instance decl not an orphan, then the act of looking at the
  TyCon or Class will force in the defining module for the
  TyCon/Class, and hence the instance decl

* BUT, if the TyCon is a wired-in TyCon, we don't really need its interface;
  but we must make sure we read its interface in case it has instances or
  rules.  That is what LoadIface.loadWiredInHomeInterface does.  It's called
  from TcIface.{tcImportDecl, checkWiredInTyCon, ifCHeckWiredInThing}

All of this is done by the type checker. The renamer plays no role.
(It used to, but no longer.)


161 162 163 164 165 166 167 168 169 170 171 172

%*********************************************************
%*							*
		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
173
loadInterface :: SDoc -> Module -> WhereFrom
174
	      -> IfM lcl (MaybeErr Message ModIface)
175

176 177 178
-- 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). 

179 180 181 182 183 184 185
-- 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 
186
-- is no longer used
187

188
loadInterface doc_str mod from
189
  = do	{ 	-- Read the state
190
	  (eps,hpt) <- getEpsAndHpt
191

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

194
		-- Check whether we have the interface already
Simon Marlow's avatar
Simon Marlow committed
195 196
 	; dflags <- getDOpts
	; case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of {
197
	    Just iface 
198
		-> return (Succeeded iface) ;	-- Already loaded
199 200
			-- The (src_imp == mi_boot iface) test checks that the already-loaded
			-- interface isn't a boot iface.  This can conceivably happen,
201
			-- if an earlier import had a before we got to real imports.   I think.
Ian Lynagh's avatar
Ian Lynagh committed
202
	    _ -> do {
203

Simon Marlow's avatar
Simon Marlow committed
204
          let { hi_boot_file = case from of
205
				ImportByUser usr_boot -> usr_boot
206
				ImportBySystem        -> sys_boot
207

Simon Marlow's avatar
Simon Marlow committed
208
	      ; mb_dep   = lookupUFM (eps_is_boot eps) (moduleName mod)
209 210 211 212 213 214 215
	      ; sys_boot = case mb_dep of
				Just (_, is_boot) -> is_boot
				Nothing		  -> False
			-- The boot-ness of the requested interface, 
	      }		-- based on the dependencies in directly-imported modules

	-- READ THE MODULE IN
Simon Marlow's avatar
Simon Marlow committed
216
	; read_result <- findAndReadIface doc_str mod hi_boot_file
217
	; case read_result of {
218
	    Failed err -> do
Simon Marlow's avatar
Simon Marlow committed
219
	  	{ let fake_iface = emptyModIface mod
220 221 222 223

		; updateEps_ $ \eps ->
			eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface }
			-- Not found, so add an empty iface to 
224
			-- the EPS map so that we don't look again
225
				
226
		; return (Failed err) } ;
227 228

	-- Found and parsed!
229
	    Succeeded (iface, file_path) 	-- Sanity check:
Simon Marlow's avatar
Simon Marlow committed
230 231 232 233
		| ImportBySystem <- from,	--   system-importing...
		  modulePackageId (mi_module iface) == thisPackage dflags,
		  				--   a home-package module...
		  Nothing <- mb_dep		--   that we know nothing about
234
		-> return (Failed (badDepMsg mod))
235

236
		| otherwise ->
237

238
	let 
239
	    loc_doc = text file_path
240 241
	in 
	initIfaceLcl mod loc_doc $ do
242 243 244 245 246 247 248 249 250

	-- 	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
251
	--	IfaceDecls, IfaceInst, IfaceFamInst, IfaceRules, IfaceVectInfo
252 253 254 255 256 257 258
	-- 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)

259 260 261 262 263
	; ignore_prags      <- doptM Opt_IgnoreInterfacePragmas
	; new_eps_decls     <- loadDecls ignore_prags (mi_decls iface)
	; new_eps_insts     <- mapM tcIfaceInst (mi_insts iface)
	; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
	; new_eps_rules     <- tcIfaceRules ignore_prags (mi_rules iface)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
264 265
        ; new_eps_vect_info <- tcIfaceVectInfo mod (mkNameEnv new_eps_decls) 
                                               (mi_vect_info iface)
266

267 268 269 270 271
	; 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",
				mi_rules     = panic "No mi_rules in PIT"
272 273
                              }
               }
274 275

	; updateEps_  $ \ eps -> 
276 277 278 279 280 281 282 283 284
	    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,
285 286
              eps_vect_info    = plusVectInfo (eps_vect_info eps) 
                                              new_eps_vect_info,
287 288 289 290 291 292 293 294 295
              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,
296 297
	      eps_stats        = addEpsInStats (eps_stats eps) 
					       (length new_eps_decls)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
298 299
					       (length new_eps_insts)
					       (length new_eps_rules) }
300

301 302 303
	; return (Succeeded final_iface)
    }}}}

Ian Lynagh's avatar
Ian Lynagh committed
304
badDepMsg :: Module -> SDoc
305
badDepMsg mod 
Ian Lynagh's avatar
Ian Lynagh committed
306 307 308
  = 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")])
309 310 311 312 313 314 315 316

-----------------------------------------------------
--	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
317 318 319 320
--
-- 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).
321 322
-----------------------------------------------------

323 324 325 326
addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv
addDeclsToPTE pte things = extendNameEnvList pte things

loadDecls :: Bool
327
	  -> [(Fingerprint, IfaceDecl)]
328 329 330 331 332 333
	  -> IfL [(Name,TyThing)]
loadDecls ignore_prags ver_decls
   = do { mod <- getIfModule
 	; thingss <- mapM (loadDecl ignore_prags mod) ver_decls
	; return (concat thingss)
	}
334

335
loadDecl :: Bool		    -- Don't load pragmas into the decl pool
336
	 -> Module
337
	  -> (Fingerprint, IfaceDecl)
338 339
	  -> IfL [(Name,TyThing)]   -- The list can be poked eagerly, but the
				    -- TyThings are forkM'd thunks
340
loadDecl ignore_prags mod (_version, decl)
341 342
  = do 	{ 	-- Populate the name cache with final versions of all 
		-- the names associated with the decl
343
	  main_name      <- lookupOrig mod (ifName decl)
344
--        ; traceIf (text "Loading decl for " <> ppr main_name)
345
	; implicit_names <- mapM (lookupOrig mod) (ifaceDeclSubBndrs decl)
346 347

	-- Typecheck the thing, lazily
348
	-- NB. Firstly, the laziness is there in case we never need the
349 350 351 352
	-- 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.
353 354 355 356

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

357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 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
        -- 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
        -- *Name*s n and the map from *OccName*s to the implicit TyThings
412 413 414
	; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]
	      lookup n = case lookupOccEnv mini_env (getOccName n) of
			   Just thing -> thing
415
			   Nothing    -> 
416
			     pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl))
417

418
	; return $ (main_name, thing) :
419 420 421
                      -- uses the invariant that implicit_names and
                      -- implictTyThings are bijective
                      [(n, lookup n) | n <- implicit_names]
422
	}
423
  where
Ian Lynagh's avatar
Ian Lynagh committed
424
    doc = ptext (sLit "Declaration for") <+> ppr (ifName decl)
425

426 427 428 429 430 431
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 } })
	}
432 433 434 435 436 437 438 439 440 441
\end{code}


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

\begin{code}
Simon Marlow's avatar
Simon Marlow committed
442
findAndReadIface :: SDoc -> Module
443 444
		 -> IsBootInterface	-- True  <=> Look for a .hi-boot file
					-- False <=> Look for .hi file
445
		 -> TcRnIf gbl lcl (MaybeErr Message (ModIface, FilePath))
446 447 448 449 450 451
	-- 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
452
findAndReadIface doc_str mod hi_boot_file
Ian Lynagh's avatar
Ian Lynagh committed
453
  = do	{ traceIf (sep [hsep [ptext (sLit "Reading"), 
454
			      if hi_boot_file 
Ian Lynagh's avatar
Ian Lynagh committed
455
				then ptext (sLit "[boot]") 
456
				else empty,
Ian Lynagh's avatar
Ian Lynagh committed
457
			      ptext (sLit "interface for"), 
Simon Marlow's avatar
Simon Marlow committed
458
			      ppr mod <> semi],
Ian Lynagh's avatar
Ian Lynagh committed
459
		        nest 4 (ptext (sLit "reason:") <+> doc_str)])
460 461

	-- Check for GHC.Prim, and return its static interface
462
	; dflags <- getDOpts
Simon Marlow's avatar
Simon Marlow committed
463
	; if mod == gHC_PRIM
464
	  then return (Succeeded (ghcPrimIface,
Simon Marlow's avatar
Simon Marlow committed
465
				   "<built in interface for GHC.Prim>"))
466 467 468
	  else do

	-- Look for the file
469
	; hsc_env <- getTopEnv
470
	; mb_found <- liftIO (findExactModule hsc_env mod)
471
	; case mb_found of {
Simon Marlow's avatar
Simon Marlow committed
472 473
              
	      Found loc mod -> do 
474 475

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

        ; if thisPackage dflags == modulePackageId mod
                && not (isOneShot (ghcMode dflags))
480
            then return (Failed (homeModError mod loc))
Simon Marlow's avatar
Simon Marlow committed
481 482
            else do {

Ian Lynagh's avatar
Ian Lynagh committed
483
        ; traceIf (ptext (sLit "readIFace") <+> text file_path)
Simon Marlow's avatar
Simon Marlow committed
484
	; read_result <- readIface mod file_path hi_boot_file
485
	; case read_result of
486
	    Failed err -> return (Failed (badIfaceFile file_path err))
487
	    Succeeded iface 
Simon Marlow's avatar
Simon Marlow committed
488 489
		| mi_module iface /= mod ->
		  return (Failed (wrongIfaceModErr iface mod file_path))
490
		| otherwise ->
491
		  return (Succeeded (iface, file_path))
492
			-- Don't forget to fill in the package name...
Ian Lynagh's avatar
Ian Lynagh committed
493 494 495 496 497 498 499 500
	}}
	    ; err -> do
		{ traceIf (ptext (sLit "...not found"))
		; dflags <- getDOpts
		; return (Failed (cannotFindInterface dflags 
					(moduleName mod) err)) }
        }
        }
501 502 503 504 505
\end{code}

@readIface@ tries just the one file.

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

Ian Lynagh's avatar
Ian Lynagh committed
511 512
readIface wanted_mod file_path _
  = do	{ res <- tryMostM $
513
                 readBinIface CheckHiWay QuietBinIFaceReading file_path
514
	; case res of
515 516 517 518 519 520 521 522
	    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)))
523
    }
524 525 526 527 528 529 530 531 532 533 534 535 536
\end{code}


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

\begin{code}
initExternalPackageState :: ExternalPackageState
initExternalPackageState
  = EPS { 
537 538 539 540 541 542
      eps_is_boot      = emptyUFM,
      eps_PIT          = emptyPackageIfaceTable,
      eps_PTE          = emptyTypeEnv,
      eps_inst_env     = emptyInstEnv,
      eps_fam_inst_env = emptyFamInstEnv,
      eps_rule_base    = mkRuleBase builtinRules,
543
	-- Initialise the EPS rule pool with the built-in rules
544 545
      eps_mod_fam_inst_env
                       = emptyModuleEnv,
546
      eps_vect_info    = noVectInfo,
547 548 549
      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 }
550 551 552 553 554 555 556 557 558 559 560 561 562
    }
\end{code}


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

\begin{code}
ghcPrimIface :: ModIface
ghcPrimIface
Simon Marlow's avatar
Simon Marlow committed
563
  = (emptyModIface gHC_PRIM) {
564
	mi_exports  = [(gHC_PRIM, ghcPrimExports)],
565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582
	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 
583
  = hcat [text "Renamer stats: ", msg]
584
  where
585 586 587 588 589 590 591 592 593
    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"]
594
	]
SamB's avatar
SamB committed
595
\end{code}
596 597


598 599 600 601 602 603 604
%************************************************************************
%*				 					*
		Printing interfaces
%*				 					*
%************************************************************************

\begin{code}
605 606 607
-- | Read binary interface, and print it out
showIface :: HscEnv -> FilePath -> IO ()
showIface hsc_env filename = do
Ian Lynagh's avatar
Ian Lynagh committed
608
   -- skip the hi way check; we don't want to worry about profiled vs.
609
   -- non-profiled interfaces, for example.
610 611
   iface <- initTcRnIf 's' hsc_env () () $
       readBinIface IgnoreHiWay TraceBinIFaceReading filename
612 613 614 615 616 617 618
   printDump (pprModIface iface)
\end{code}

\begin{code}
pprModIface :: ModIface -> SDoc
-- Show a ModIface
pprModIface iface
Ian Lynagh's avatar
Ian Lynagh committed
619
 = vcat [ ptext (sLit "interface")
620
		<+> ppr (mi_module iface) <+> pp_boot
Ian Lynagh's avatar
Ian Lynagh committed
621 622 623
		<+> (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)
624
		<+> integer opt_HiVersion
625 626 627 628 629
        , 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"))
630 631 632 633 634 635
	, vcat (map pprExport (mi_exports iface))
	, pprDeps (mi_deps iface)
	, vcat (map pprUsage (mi_usages iface))
	, pprFixities (mi_fixities iface)
	, vcat (map pprIfaceDecl (mi_decls iface))
	, vcat (map ppr (mi_insts iface))
636
	, vcat (map ppr (mi_fam_insts iface))
637
	, vcat (map ppr (mi_rules iface))
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
638
        , pprVectInfo (mi_vect_info iface)
639
	, pprDeprecs (mi_deprecs iface)
640
 	]
641
  where
Ian Lynagh's avatar
Ian Lynagh committed
642
    pp_boot | mi_boot iface = ptext (sLit "[boot]")
643 644 645 646 647 648 649 650 651 652 653
	    | 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
654
 = hsep [ ptext (sLit "export"), ppr mod, hsep (map pp_avail items) ]
655 656 657 658 659 660 661 662 663 664 665 666
  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
667 668 669 670 671 672 673 674 675 676
pprUsage usage@UsagePackageModule{}
  = hsep [ptext (sLit "import"), ppr (usg_mod usage), 
	  ppr (usg_mod_hash usage)]
pprUsage usage@UsageHomeModule{}
  = hsep [ptext (sLit "import"), ppr (usg_mod_name usage), 
	  ppr (usg_mod_hash usage)] $$
    nest 2 (
	maybe empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$
        vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]
        )
677 678

pprDeps :: Dependencies -> SDoc
679 680
pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,
		dep_finsts = finsts })
Ian Lynagh's avatar
Ian Lynagh committed
681 682 683 684
  = vcat [ptext (sLit "module dependencies:") <+> fsep (map ppr_mod mods),
	  ptext (sLit "package dependencies:") <+> fsep (map ppr pkgs), 
	  ptext (sLit "orphans:") <+> fsep (map ppr orphs),
	  ptext (sLit "family instance modules:") <+> fsep (map ppr finsts)
685 686 687 688 689 690
	]
  where
    ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot
    ppr_boot True  = text "[boot]"
    ppr_boot False = empty

691
pprIfaceDecl :: (Fingerprint, IfaceDecl) -> SDoc
692
pprIfaceDecl (ver, decl)
693
  = ppr ver $$ nest 2 (ppr decl)
694 695 696

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

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
701
pprVectInfo :: IfaceVectInfo -> SDoc
702 703 704
pprVectInfo (IfaceVectInfo { ifaceVectInfoVar        = vars
                           , ifaceVectInfoTyCon      = tycons
                           , ifaceVectInfoTyConReuse = tyconsReuse
705 706
                           }) = 
  vcat 
Ian Lynagh's avatar
Ian Lynagh committed
707 708 709
  [ 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)
710
  ]
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
711

Ian Lynagh's avatar
Ian Lynagh committed
712
pprDeprecs :: Deprecations -> SDoc
713
pprDeprecs NoDeprecs	    = empty
Ian Lynagh's avatar
Ian Lynagh committed
714 715
pprDeprecs (DeprecAll txt)  = ptext (sLit "Deprecate all") <+> doubleQuotes (ftext txt)
pprDeprecs (DeprecSome prs) = ptext (sLit "Deprecate") <+> vcat (map pprDeprec prs)
716 717 718 719 720
			    where
			      pprDeprec (name, txt) = ppr name <+> doubleQuotes (ftext txt)
\end{code}


721 722 723 724 725 726 727
%*********************************************************
%*						 	 *
\subsection{Errors}
%*							 *
%*********************************************************

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
728
badIfaceFile :: String -> SDoc -> SDoc
729
badIfaceFile file err
Ian Lynagh's avatar
Ian Lynagh committed
730
  = vcat [ptext (sLit "Bad interface file:") <+> text file, 
731 732
	  nest 4 err]

733
hiModuleNameMismatchWarn :: Module -> Module -> Message
734
hiModuleNameMismatchWarn requested_mod read_mod = 
Simon Marlow's avatar
Simon Marlow committed
735 736 737
  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
738
    hsep [ ptext (sLit "Something is amiss; requested module ")
739
	 , ppr requested_mod
Ian Lynagh's avatar
Ian Lynagh committed
740
	 , ptext (sLit "differs from name found in the interface file")
741 742 743
   	 , ppr read_mod
  	 ]

Ian Lynagh's avatar
Ian Lynagh committed
744
wrongIfaceModErr :: ModIface -> Module -> String -> SDoc
745
wrongIfaceModErr iface mod_name file_path 
Ian Lynagh's avatar
Ian Lynagh committed
746 747 748 749
  = 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"),
750
	     nest 2 iface_file,
Ian Lynagh's avatar
Ian Lynagh committed
751
	     ptext (sLit "has an incompatible module name")
752 753 754
	    ]
	]
  where iface_file = doubleQuotes (text file_path)
Simon Marlow's avatar
Simon Marlow committed
755

Ian Lynagh's avatar
Ian Lynagh committed
756
homeModError :: Module -> ModLocation -> SDoc
Simon Marlow's avatar
Simon Marlow committed
757
homeModError mod location
Ian Lynagh's avatar
Ian Lynagh committed
758
  = ptext (sLit "attempting to use module ") <> quotes (ppr mod)
Simon Marlow's avatar
Simon Marlow committed
759 760 761
    <> (case ml_hs_file location of
           Just file -> space <> parens (text file)
           Nothing   -> empty)
Ian Lynagh's avatar
Ian Lynagh committed
762
    <+> ptext (sLit "which is not loaded")
763
\end{code}
764