RnIfaces.lhs 19 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
	-- 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
100
    mapRn loadExport exports					`thenRn` \ avails_s ->
101
102
    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
	 export_env = (concat avails_s, fixs)
105
106
107
108
109
110
111
112
113
114
115

			-- 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
    setIfacesRn new_ifaces		`thenRn_`
    returnRn new_ifaces
    }

121
122
123
loadExport :: ExportItem -> RnMG [AvailInfo]
loadExport (mod, entities)
  = mapRn load_entity entities
124
125
126
  where
    new_name occ = newGlobalName mod occ

127
128
129
130
131
    load_entity (occ, occs)
      =	new_name occ 		`thenRn` \ name ->
        mapRn new_name occs 	`thenRn` \ names ->
        returnRn (Avail name names)

132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
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
    )
147
  where
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
    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)
165
\end{code}
166

167

168
169
170
171
172
173
174
175
176
177
%********************************************************
%*							*
\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 ->
178
    case read_result of
179
180
181
182
183
184
185
	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
186
  where
187
188
	-- Only look in current directory, with suffix .hi
    doc_str = ppSep [ppStr "Need usage info from", pprModule PprDebug mod_name]
189
190


191
checkModUsage [] = returnRn True		-- Yes!  Everything is up to date!
192

193
194
195
196
197
198
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
199
    in
200
201
202
203
204
205
206
207
208
209
210
211
	-- 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_`
212

213
214
215
216
217
218
219
220
221
	-- 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]
222
223


224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
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
242
243
244
\end{code}


245
246
247
248
249
%*********************************************************
%*							*
\subsection{Getting in a declaration}
%*							*
%*********************************************************
250

251
252
253
254
255
256
\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
257

258
      Just avail_w_decl -> returnRn avail_w_decl
259

260
261
262
263
264
      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]
265
266
\end{code}

267
268
269
270
271
272
@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.
273

274
  * 	similarly for synonum type constructor
275

276
277
  * 	if the wired-in name is another wired-in Id, it marks as "occurrences"
	the free vars of the Id's type.
278

279
280
  *	it loads the interface file for the wired-in thing for the
	sole purpose of making sure that its instance declarations are available
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
316
317
318
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)
319

320
321
322
323
324
325
326
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)
327

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


338
339
340
341
342
%*********************************************************
%*							*
\subsection{Getting other stuff}
%*							*
%*********************************************************
343
344

\begin{code}
345
346
347
348
349
350
351
352
353
354
355
356
357
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"]
358
359


360
361
362
363
364
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_`
365

366
367
368
369
	-- Now we're ready to grab the instance declarations
    getIfacesRn						`thenRn` \ ifaces ->
    let
	 Ifaces _ _ _ _ _ insts _ = ifaces
370
    in
371
    returnRn (bagToList insts) 
372
  where
373
374
375
376
377
378
379
380
381
382
    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
383
384
385
\end{code}

\begin{code}
386
387
getImportVersions :: [AvailInfo]			-- Imported avails
		  -> RnMG (VersionInfo Name)	-- Version info for these names
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
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
417
\end{code}
418

419
420
421
422
423
424
425
426
427
428
429
430
431
%*********************************************************
%*							*
\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.

432
\begin{code}
433
434
435
getDeclBinders :: (RdrName -> SrcLoc -> RnMG Name)		-- New-name function
		-> RdrNameHsDecl
		-> RnMG AvailInfo
436

437
438
439
440
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)
441

442
443
444
445
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])
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
480
481
482
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)
483
  where
484
485
486
    fields = concat (map fst fielddecls)

getConFieldNames new_name [] = returnRn []
487

488
getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc
489
490
491
\end{code}


492
493
494
495
496
497
%*********************************************************
%*							*
\subsection{Reading an interface file}
%*							*
%*********************************************************

498
\begin{code}
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
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}
523

524
@readIface@ trys just one file.
525

526
527
528
529
530
531
532
533
534
535
\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)
536

537
	Left  (NoSuchThing _) -> returnRn Nothing
538

539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
	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}
560

561
562
563
564
565
%*********************************************************
%*							*
\subsection{Errors}
%*							*
%*********************************************************
566

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

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