RnIfaces.lhs 18.9 KB
Newer Older
1
2
3
4
5
6
7
8
9
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[RnIfaces]{Cacheing and Renaming of Interfaces}

\begin{code}
#include "HsVersions.h"

module RnIfaces (
10
11
12
13
14
15
16
17
18
19
	getInterfaceExports,
	getImportedInstDecls,
	getSpecialInstModules,
	getDecl, getWiredInDecl,
	getImportVersions,

	checkUpToDate,

	getDeclBinders,
	mkSearchPath
20
21
    ) where

22
IMP_Ubiq()
23
24


25
26
27
28
29
30
31
32
33
34
import HsSyn		( HsDecl(..), TyDecl(..), ClassDecl(..), HsTyVar, Bind, HsExpr, Sig(..), 
			  HsBinds(..), MonoBinds, DefaultDecl, ConDecl(..), HsType, BangType, IfaceSig(..),
			  FixityDecl(..), Fixity, Fake, InPat, InstDecl(..), SYN_IE(Version), HsIdInfo
			)
import HsPragmas	( noGenPragmas )
import RdrHsSyn		( SYN_IE(RdrNameHsDecl), SYN_IE(RdrNameInstDecl), 
			  RdrName, rdrNameOcc
			)
import RnEnv		( newGlobalName, lookupRn, addImplicitOccsRn, availNames )
import RnSource		( rnHsType )
35
import RnMonad
36
import ParseIface	( parseIface )
37

38
import ErrUtils		( SYN_IE(Error), SYN_IE(Warning) )
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
import FiniteMap	( FiniteMap, emptyFM, unitFM, lookupFM, addToFM, addListToFM, fmToList )
import Name		( Name {-instance NamedThing-}, Provenance, OccName(..),
			  modAndOcc, occNameString, moduleString, pprModule,
			  NameSet(..), emptyNameSet, unionNameSets, nameSetToList,
			  minusNameSet, mkNameSet,
			  isWiredInName, maybeWiredInTyConName, maybeWiredInIdName
			 )
import Id		( GenId, Id(..), idType, dataConTyCon, isDataCon )
import TyCon		( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn )
import Type		( namesOfType )
import TyVar		( GenTyVar )
import SrcLoc		( mkIfaceSrcLoc )
import PrelMods		( gHC__ )
import Bag
import Maybes		( MaybeErr(..), expectJust, maybeToBool )
import ListSetOps	( unionLists )
55
import Pretty
56
57
import PprStyle		( PprStyle(..) )
import Util		( pprPanic )
58
59
\end{code}

60
61


62
63
64
65
66
%*********************************************************
%*							*
\subsection{Loading a new interface file}
%*							*
%*********************************************************
67

68
\begin{code}
69
70
71
loadInterface :: Pretty -> Module -> RnMG Ifaces
loadInterface doc_str load_mod 
  = getIfacesRn 		`thenRn` \ ifaces ->
72
    let
73
	Ifaces this_mod mod_vers_map export_env_map vers_map decls_map inst_map inst_mods = ifaces
74
    in
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
	-- CHECK WHETHER WE HAVE IT ALREADY
    if maybeToBool (lookupFM export_env_map load_mod) 
    then
	returnRn ifaces		-- Already in the cache; don't re-read it
    else

	-- READ THE MODULE IN
    findAndReadIface doc_str load_mod		`thenRn` \ read_result ->
    case read_result of {
	-- Check for not found
	Nothing -> 	-- Not found, so add an empty export env to the Ifaces map
			-- so that we don't look again
		   let
			new_export_env_map = addToFM export_env_map load_mod ([],[])
			new_ifaces = Ifaces this_mod mod_vers_map 
					    new_export_env_map 
					    vers_map decls_map inst_map inst_mods
		   in
		   setIfacesRn new_ifaces		`thenRn_`
		   failWithRn new_ifaces (noIfaceErr load_mod) ;

	-- Found and parsed!
	Just (ParsedIface _ mod_vers usages exports rd_inst_mods fixs decls insts) ->

	-- LOAD IT INTO Ifaces
    mapRn loadExport exports					`thenRn` \ avails ->
    foldlRn (loadDecl load_mod) (decls_map,vers_map) decls	`thenRn` \ (new_decls_map, new_vers_map) ->
    foldlRn (loadInstDecl load_mod) inst_map insts		`thenRn` \ new_insts_map ->
103
    let
104
105
106
107
108
109
110
111
112
113
114
115
	 export_env = (avails, fixs)

			-- Exclude this module from the "special-inst" modules
	 new_inst_mods = inst_mods `unionLists` (filter (/= this_mod) rd_inst_mods)

	 new_ifaces = Ifaces this_mod
			     (addToFM mod_vers_map load_mod mod_vers)
			     (addToFM export_env_map load_mod export_env)
			     new_vers_map
			     new_decls_map
			     new_insts_map
			     new_inst_mods 
116
    in
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
    setIfacesRn new_ifaces		`thenRn_`
    returnRn new_ifaces
    }

loadExport :: ExportItem -> RnMG AvailInfo
loadExport (mod, occ, occs)
  = new_name occ 		`thenRn` \ name ->
    mapRn new_name occs 	`thenRn` \ names ->
    returnRn (Avail name names)
  where
    new_name occ = newGlobalName mod occ

loadVersion :: Module -> VersionMap -> (OccName,Version) -> RnMG VersionMap
loadVersion mod vers_map (occ, version)
  = newGlobalName mod occ 			`thenRn` \ name ->
    returnRn (addToFM vers_map name version)


loadDecl :: Module -> (DeclsMap, VersionMap)
	 -> (Version, RdrNameHsDecl)
	 -> RnMG (DeclsMap, VersionMap)
loadDecl mod (decls_map, vers_map) (version, decl)
  = getDeclBinders new_implicit_name decl	`thenRn` \ avail@(Avail name _) ->
    returnRn (addListToFM decls_map
			  [(name,(avail,decl)) | name <- availNames avail],
	      addToFM vers_map name version
    )
144
  where
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
    new_implicit_name rdr_name loc = newGlobalName mod (rdrNameOcc rdr_name)

loadInstDecl :: Module -> Bag IfaceInst -> RdrNameInstDecl -> RnMG (Bag IfaceInst)
loadInstDecl mod_name insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc)
  = initRnMS emptyRnEnv mod_name InterfaceMode $

	-- Find out what type constructors and classes are mentioned in the
	-- instance declaration.  We have to be a bit clever.
	--
	-- We want to rename the type so that we can find what
	-- (free) type constructors are inside it.  But we must *not* thereby
	-- put new occurrences into the global pool because otherwise we'll force
	-- them all to be loaded.  We kill two birds with ones stone by renaming
	-- with a fresh occurrence pool.
    findOccurrencesRn (rnHsType inst_ty)	`thenRn` \ ty_names ->

    returnRn ((ty_names, mod_name, decl) `consBag` insts)
162
\end{code}
163

164

165
166
167
168
169
170
171
172
173
174
%********************************************************
%*							*
\subsection{Loading usage information}
%*							*
%********************************************************

\begin{code}
checkUpToDate :: Module -> RnMG Bool		-- True <=> no need to recompile
checkUpToDate mod_name
  = findAndReadIface doc_str mod_name		`thenRn` \ read_result ->
175
    case read_result of
176
177
178
179
180
181
182
	Nothing -> 	-- Old interface file not found, so we'd better bale out
		    traceRn (ppSep [ppStr "Didnt find old iface", pprModule PprDebug mod_name])	`thenRn_`
		    returnRn False

	Just (ParsedIface _ _ usages _ _ _ _ _) 
		-> 	-- Found it, so now check it
		    checkModUsage usages
183
  where
184
185
	-- Only look in current directory, with suffix .hi
    doc_str = ppSep [ppStr "Need usage info from", pprModule PprDebug mod_name]
186
187


188
checkModUsage [] = returnRn True		-- Yes!  Everything is up to date!
189

190
191
192
193
194
195
checkModUsage ((mod, old_mod_vers, old_local_vers) : rest)
  = loadInterface doc_str mod		`thenRn` \ ifaces ->
    let
	Ifaces _ mod_vers_map _ new_vers_map _ _ _ = ifaces
	maybe_new_mod_vers = lookupFM mod_vers_map mod
	Just new_mod_vers  = maybe_new_mod_vers
196
    in
197
198
199
200
201
202
203
204
205
206
207
208
	-- If we can't find a version number for the old module then
	-- bale out saying things aren't up to date
    if not (maybeToBool maybe_new_mod_vers) then
	returnRn False
    else

	-- If the module version hasn't changed, just move on
    if new_mod_vers == old_mod_vers then
	traceRn (ppSep [ppStr "Module version unchanged:", pprModule PprDebug mod])	`thenRn_`
	checkModUsage rest
    else
    traceRn (ppSep [ppStr "Module version has changed:", pprModule PprDebug mod])	`thenRn_`
209

210
211
212
213
214
215
216
217
218
	-- New module version, so check entities inside
    checkEntityUsage mod new_vers_map old_local_vers	`thenRn` \ up_to_date ->
    if up_to_date then
	traceRn (ppStr "...but the bits I use havn't.")	`thenRn_`
	checkModUsage rest	-- This one's ok, so check the rest
    else
	returnRn False		-- This one failed, so just bail out now
  where
    doc_str = ppSep [ppStr "need version info for", pprModule PprDebug mod]
219
220


221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
checkEntityUsage mod new_vers_map [] 
  = returnRn True	-- Yes!  All up to date!

checkEntityUsage mod new_vers_map ((occ_name,old_vers) : rest)
  = newGlobalName mod occ_name		`thenRn` \ name ->
    case lookupFM new_vers_map name of

	Nothing       -> 	-- We used it before, but it ain't there now
			  traceRn (ppSep [ppStr "...and this no longer exported:", ppr PprDebug name])	`thenRn_`
			  returnRn False

	Just new_vers -> 	-- It's there, but is it up to date?
			  if new_vers == old_vers then
				-- Up to date, so check the rest
				checkEntityUsage mod new_vers_map rest
			  else
				traceRn (ppSep [ppStr "...and this is out of date:", ppr PprDebug name])  `thenRn_`
			        returnRn False	-- Out of date, so bale out
239
240
241
\end{code}


242
243
244
245
246
%*********************************************************
%*							*
\subsection{Getting in a declaration}
%*							*
%*********************************************************
247

248
249
250
251
252
253
\begin{code}
getDecl :: Name -> RnMG (AvailInfo, RdrNameHsDecl)
getDecl name
  = traceRn doc_str 			`thenRn_`
    loadInterface doc_str mod		`thenRn` \ (Ifaces _ _ _ _ decls_map _ _) ->
    case lookupFM decls_map name of
254

255
      Just avail_w_decl -> returnRn avail_w_decl
256

257
258
259
260
261
      Nothing   	-> 	-- Can happen legitimately for "Optional" occurrences
			   returnRn (NotAvailable, ValD EmptyBinds)
  where
     (mod,_) = modAndOcc name
     doc_str = ppSep [ppStr "Need decl for", ppr PprDebug name]
262
263
\end{code}

264
265
266
267
268
269
@getWiredInDecl@ maps a wired-in @Name@ to what it makes available.
It behaves exactly as if the wired in decl were actually in an interface file.
Specifically,
  *	if the wired-in name is a data type constructor or a data constructor, 
	it brings in the type constructor and all the data constructors; and
	marks as "occurrences" any free vars of the data con.
270

271
  * 	similarly for synonum type constructor
272

273
274
  * 	if the wired-in name is another wired-in Id, it marks as "occurrences"
	the free vars of the Id's type.
275

276
277
  *	it loads the interface file for the wired-in thing for the
	sole purpose of making sure that its instance declarations are available
278

279
280
281
282
283
284
285
286
287
288
289
290
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
All this is necessary so that we know all types that are "in play", so
that we know just what instances to bring into scope.
	
\begin{code}
getWiredInDecl :: Name -> RnMG AvailInfo
getWiredInDecl name
  = 	-- Force in the home module in case it has instance decls for
	-- the thing we are interested in
    (if mod == gHC__ then
	returnRn ()			-- Mini hack; GHC is guaranteed not to have
					-- instance decls, so it's a waste of time
					-- to read it
    else
	loadInterface doc_str mod	`thenRn_`
	returnRn ()
    )					 	`thenRn_`

    if (maybeToBool maybe_wired_in_tycon) then
	get_wired_tycon the_tycon
    else				-- Must be a wired-in-Id
    if (isDataCon the_id) then		-- ... a wired-in data constructor
	get_wired_tycon (dataConTyCon the_id)
    else				-- ... a wired-in non data-constructor
   	get_wired_id the_id
  where
    doc_str = ppSep [ppStr "Need home module for wired in thing", ppr PprDebug name]
    (mod,_) = modAndOcc name
    maybe_wired_in_tycon = maybeWiredInTyConName name
    maybe_wired_in_id    = maybeWiredInIdName    name
    Just the_tycon	 = maybe_wired_in_tycon
    Just the_id 	 = maybe_wired_in_id

get_wired_id id
  = addImplicitOccsRn (nameSetToList id_mentioned)	`thenRn_`
    returnRn (Avail (getName id) [])
  where
    id_mentioned	 = namesOfType (idType id)
316

317
318
319
320
321
322
323
get_wired_tycon tycon 
  | isSynTyCon tycon
  = addImplicitOccsRn (nameSetToList mentioned)		`thenRn_`
    returnRn (Avail (getName tycon) [])
  where
    (tyvars,ty) = getSynTyConDefn tycon
    mentioned = namesOfType ty `minusNameSet` mkNameSet (map getName tyvars)
324

325
326
327
328
get_wired_tycon tycon 
  | otherwise		-- data or newtype
  = addImplicitOccsRn (nameSetToList mentioned)		`thenRn_`
    returnRn (Avail (getName tycon) (map getName data_cons))
329
  where
330
331
    data_cons = tyConDataCons tycon
    mentioned = foldr (unionNameSets . namesOfType . idType) emptyNameSet data_cons
332
333
334
\end{code}


335
336
337
338
339
%*********************************************************
%*							*
\subsection{Getting other stuff}
%*							*
%*********************************************************
340
341

\begin{code}
342
343
344
345
346
347
348
349
350
351
352
353
354
getInterfaceExports :: Module -> RnMG (Avails, [(OccName,Fixity)])
getInterfaceExports mod
  = loadInterface doc_str mod		`thenRn` \ (Ifaces _ _ export_envs _ _ _ _) ->
    case lookupFM export_envs mod of
	Nothing ->	-- Not there; it must be that the interface file wasn't found;
			-- the error will have been reported already.
			-- (Actually loadInterface should put the empty export env in there
			--  anyway, but this does no harm.)
		      returnRn ([],[])

	Just stuff -> returnRn stuff
  where
    doc_str = ppSep [pprModule PprDebug mod, ppStr "is directly imported"]
355
356


357
358
359
360
361
getImportedInstDecls :: RnMG [IfaceInst]
getImportedInstDecls
  = 	-- First load any special-instance modules that aren't aready loaded
    getSpecialInstModules 			`thenRn` \ inst_mods ->
    mapRn load_it inst_mods			`thenRn_`
362

363
364
365
366
	-- Now we're ready to grab the instance declarations
    getIfacesRn						`thenRn` \ ifaces ->
    let
	 Ifaces _ _ _ _ _ insts _ = ifaces
367
    in
368
    returnRn (bagToList insts) 
369
  where
370
371
372
373
374
375
376
377
378
379
    load_it mod = loadInterface (doc_str mod) mod
    doc_str mod = ppSep [pprModule PprDebug mod, ppStr "is a special-instance module"]

getSpecialInstModules :: RnMG [Module]
getSpecialInstModules 
  = getIfacesRn						`thenRn` \ ifaces ->
    let
	 Ifaces _ _ _ _ _ _ inst_mods = ifaces
    in
    returnRn inst_mods
380
381
382
\end{code}

\begin{code}
383
384
getImportVersions :: [AvailInfo]			-- Imported avails
		  -> RnMG (VersionInfo Name)	-- Version info for these names
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
getImportVersions imported_avails	
  = getIfacesRn					`thenRn` \ ifaces ->
    let
	 Ifaces _ mod_versions_map _ version_map _ _ _ = ifaces

	 -- import_versions is harder: we have to group together all the things imported
	 -- from a particular module.  We do this with yet another finite map

	 mv_map :: FiniteMap Module [LocalVersion Name]
	 mv_map		   = foldl add_mv emptyFM imported_avails
	 add_mv mv_map (Avail name _) 
	    | isWiredInName name = mv_map	-- Don't record versions for wired-in names
	    | otherwise = case lookupFM mv_map mod of
				Just versions -> addToFM mv_map mod ((name,version):versions)
				Nothing       -> addToFM mv_map mod [(name,version)]
	    where
	     (mod,_) = modAndOcc name
	     version = case lookupFM version_map name of
			 Just v  -> v
			 Nothing -> pprPanic "getVersionInfo:" (ppr PprDebug name)

	 import_versions = [ (mod, expectJust "import_versions" (lookupFM mod_versions_map mod), local_versions)
			   | (mod, local_versions) <- fmToList mv_map
			   ]

	 -- Question: should we filter the builtins out of import_versions?
    in
    returnRn import_versions
414
\end{code}
415

416
417
418
419
420
421
422
423
424
425
426
427
428
%*********************************************************
%*							*
\subsection{Getting binders out of a declaration}
%*							*
%*********************************************************

@getDeclBinders@ returns the names for a @RdrNameHsDecl@.
It's used for both source code (from @availsFromDecl@) and interface files
(from @loadDecl@).

It doesn't deal with source-code specific things: ValD, DefD.  They
are handled by the sourc-code specific stuff in RnNames.

429
\begin{code}
430
431
432
getDeclBinders :: (RdrName -> SrcLoc -> RnMG Name)		-- New-name function
		-> RdrNameHsDecl
		-> RnMG AvailInfo
433

434
435
436
437
getDeclBinders new_name (TyD (TyData _ tycon _ condecls _ _ src_loc))
  = new_name tycon src_loc			`thenRn` \ tycon_name ->
    getConFieldNames new_name condecls		`thenRn` \ sub_names ->
    returnRn (Avail tycon_name sub_names)
438

439
440
441
442
getDeclBinders new_name (TyD (TyNew _ tycon _ (NewConDecl con _ con_loc) _ _ src_loc))
  = new_name tycon src_loc		`thenRn` \ tycon_name ->
    new_name con src_loc		`thenRn` \ con_name ->
    returnRn (Avail tycon_name [con_name])
443

444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
getDeclBinders new_name (TyD (TySynonym tycon _ _ src_loc))
  = new_name tycon src_loc		`thenRn` \ tycon_name ->
    returnRn (Avail tycon_name [])

getDeclBinders new_name (ClD (ClassDecl _ cname _ sigs _ _ src_loc))
  = new_name cname src_loc			`thenRn` \ class_name ->
    mapRn (getClassOpNames new_name) sigs	`thenRn` \ sub_names ->
    returnRn (Avail class_name sub_names)

getDeclBinders new_name (SigD (IfaceSig var ty prags src_loc))
  = new_name var src_loc			`thenRn` \ var_name ->
    returnRn (Avail var_name [])

getDeclBinders new_name (DefD _)  = returnRn NotAvailable
getDeclBinders new_name (InstD _) = returnRn NotAvailable

----------------
getConFieldNames new_name (ConDecl con _ src_loc : rest)
  = new_name con src_loc		`thenRn` \ n ->
    getConFieldNames new_name rest	`thenRn` \ ns -> 
    returnRn (n:ns)

getConFieldNames new_name (NewConDecl con _ src_loc : rest)
  = new_name con src_loc		`thenRn` \ n ->
    getConFieldNames new_name rest	`thenRn` \ ns -> 
    returnRn (n:ns)

getConFieldNames new_name (ConOpDecl _ con _ src_loc : rest)
  = new_name con src_loc		`thenRn` \ n ->
    getConFieldNames new_name rest	`thenRn` \ ns -> 
    returnRn (n:ns)

getConFieldNames new_name (RecConDecl con fielddecls src_loc : rest)
  = mapRn (\n -> new_name n src_loc) (con:fields)	`thenRn` \ cfs ->
    getConFieldNames new_name rest			`thenRn` \ ns  -> 
    returnRn (cfs ++ ns)
480
  where
481
482
483
    fields = concat (map fst fielddecls)

getConFieldNames new_name [] = returnRn []
484

485
getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc
486
487
488
\end{code}


489
490
491
492
493
494
%*********************************************************
%*							*
\subsection{Reading an interface file}
%*							*
%*********************************************************

495
\begin{code}
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
findAndReadIface :: Pretty -> Module -> RnMG (Maybe ParsedIface)
	-- Nothing <=> file not found, or unreadable, or illegible
	-- Just x  <=> successfully found and parsed 
findAndReadIface doc_str mod
  = traceRn trace_msg			`thenRn_`
    getSearchPathRn			`thenRn` \ dirs ->
    try dirs dirs
  where
    trace_msg = ppHang (ppBesides [ppStr "Reading interface for ", 
				   pprModule PprDebug mod, ppSemi])
		     4 (ppBesides [ppStr "reason: ", doc_str])

    try all_dirs [] = traceRn (ppStr "...failed")	`thenRn_`
		      returnRn Nothing

    try all_dirs (dir:dirs)
	= readIface file_path	`thenRn` \ read_result ->
	  case read_result of
		Nothing    -> try all_dirs dirs
		Just iface -> traceRn (ppStr "...done")	`thenRn_`
			      returnRn (Just iface)
	where
	  file_path = dir ++ "/" ++ moduleString mod ++ ".hi"
\end{code}
520

521
@readIface@ trys just one file.
522

523
524
525
526
527
528
529
530
531
532
\begin{code}
readIface :: String -> RnMG (Maybe ParsedIface)	
	-- Nothing <=> file not found, or unreadable, or illegible
	-- Just x  <=> successfully found and parsed 
readIface file_path
  = ioToRnMG (readFile file_path)  	`thenRn` \ read_result ->
    case read_result of
	Right contents	  -> case parseIface contents of
				Failed err      -> failWithRn Nothing err 
				Succeeded iface -> returnRn (Just iface)
533

534
	Left  (NoSuchThing _) -> returnRn Nothing
535

536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
	Left  err	      -> failWithRn Nothing
					    (cannaeReadFile file_path err)

\end{code}

mkSearchPath takes a string consisting of a colon-separated list of directories, and turns it into
a list of directories.  For example:

	mkSearchPath "foo:.:baz"  =  ["foo", ".", "baz"]

\begin{code}
mkSearchPath :: Maybe String -> SearchPath
mkSearchPath Nothing = ["."]
mkSearchPath (Just s)
  = go s
  where
    go "" = []
    go s  = first : go (drop 1 rest)
	  where
	    (first,rest) = span (/= ':') s
\end{code}
557

558
559
560
561
562
%*********************************************************
%*							*
\subsection{Errors}
%*							*
%*********************************************************
563

564
565
566
567
\begin{code}
noIfaceErr mod sty
  = ppBesides [ppStr "Could not find interface for ", ppQuote (pprModule sty mod)]
--	, ppStr " in"]) 4 (ppAboves (map ppStr dirs))
568

569
570
cannaeReadFile file err sty
  = ppBesides [ppPStr SLIT("Failed in reading file: "), ppStr file, ppStr "; error=", ppStr (show err)]
571
\end{code}