2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[MkIface]{Print an interface for a module}
8 mkModDetails, mkModDetailsFromIface, completeIface,
12 #include "HsVersions.h"
15 import HsCore ( HsIdInfo(..), UfExpr(..), toUfExpr, toUfBndr )
16 import HsTypes ( toHsTyVars )
17 import BasicTypes ( Fixity(..), NewOrData(..),
18 Version, initialVersion, bumpVersion,
21 import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl )
22 import TcHsSyn ( TypecheckedRuleDecl )
23 import HscTypes ( VersionInfo(..), ModIface(..), ModDetails(..),
24 IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
25 TyThing(..), DFunId, TypeEnv, Avails,
26 WhatsImported(..), GenAvailInfo(..),
27 ImportVersion, AvailInfo, Deprecations(..),
32 import Id ( Id, idType, idInfo, isImplicitId, isDictFunId,
33 idSpecialisation, setIdInfo, isLocalId, idName, hasNoBinding
37 import DataCon ( StrictnessMark(..), dataConId, dataConSig, dataConFieldLabels, dataConStrictMarks )
39 import CoreSyn ( CoreBind, CoreRule(..), IdCoreRule,
40 isBuiltinRule, rulesRules,
41 bindersOf, bindersOfBinds
43 import CoreFVs ( ruleSomeLhsFreeVars )
44 import CoreUnfold ( neverUnfold, unfoldingTemplate )
45 import Name ( getName, nameModule, Name, NamedThing(..) )
47 import OccName ( pprOccName )
48 import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyConGenIds,
49 tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize, isClassTyCon
51 import Class ( classExtraBigSig, classTyCon, DefMeth(..) )
52 import FieldLabel ( fieldLabelType )
53 import Type ( splitSigmaTy, tidyTopType, deNoteType )
54 import SrcLoc ( noSrcLoc )
56 import Module ( ModuleName )
58 import IO ( IOMode(..), openFile, hClose )
62 %************************************************************************
64 \subsection{Write a new interface file}
66 %************************************************************************
69 mkModDetails :: TypeEnv -- From typechecker
70 -> [CoreBind] -- Final bindings
71 -- they have authoritative arity info
72 -> [IdCoreRule] -- Tidy orphan rules
74 mkModDetails type_env tidy_binds orphan_rules
75 = ModDetails { md_types = new_type_env,
77 md_insts = filter isDictFunId final_ids }
79 -- The competed type environment is gotten from
80 -- a) keeping the types and classes
81 -- b) removing all Ids,
82 -- c) adding Ids with correct IdInfo, including unfoldings,
83 -- gotten from the bindings
84 -- From (c) we keep only those Ids with Global names;
85 -- the CoreTidy pass makes sure these are all and only
86 -- the externally-accessible ones
87 -- This truncates the type environment to include only the
88 -- exported Ids and things needed from them, which saves space
90 -- However, we do keep things like constructors, which should not appear
91 -- in interface files, because they are needed by importing modules when
92 -- using the compilation manager
93 new_type_env = extendTypeEnvList (filterNameEnv keep_it type_env)
96 -- We keep constructor workers, because they won't appear
97 -- in the bindings from which final_ids are derived!
98 keep_it (AnId id) = hasNoBinding id
101 final_ids = [id | bind <- tidy_binds
102 , id <- bindersOf bind
103 , isGlobalName (idName id)]
105 -- The complete rules are gotten by combining
106 -- a) the orphan rules
107 -- b) rules embedded in the top-level Ids
108 rule_dcls | opt_OmitInterfacePragmas = []
109 | otherwise = getRules orphan_rules tidy_binds (mkVarSet final_ids)
111 -- This version is used when we are re-linking a module
112 -- so we've only run the type checker on its previous interface
113 mkModDetailsFromIface :: TypeEnv
114 -> [TypecheckedRuleDecl]
116 mkModDetailsFromIface type_env rules
117 = ModDetails { md_types = type_env,
118 md_rules = rule_dcls,
119 md_insts = dfun_ids }
121 dfun_ids = [dfun_id | AnId dfun_id <- nameEnvElts type_env, isDictFunId dfun_id]
122 rule_dcls = [(id,rule) | IfaceRuleOut id rule <- rules]
123 -- All the rules from an interface are of the IfaceRuleOut form
127 getRules :: [IdCoreRule] -- Orphan rules
128 -> [CoreBind] -- Bindings, with rules in the top-level Ids
129 -> IdSet -- Ids that are exported, so we need their rules
131 getRules orphan_rules binds emitted
132 = orphan_rules ++ local_rules
134 local_rules = [ (fn, rule)
135 | fn <- bindersOfBinds binds,
136 fn `elemVarSet` emitted,
137 rule <- rulesRules (idSpecialisation fn),
138 not (isBuiltinRule rule),
139 -- We can't print builtin rules in interface files
140 -- Since they are built in, an importing module
141 -- will have access to them anyway
143 -- Sept 00: I've disabled this test. It doesn't stop many, if any, rules
144 -- from coming out, and to make it work properly we need to add ????
145 -- (put it back in for now)
146 all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
147 -- Spit out a rule only if all its lhs free vars are emitted
148 -- This is a good reason not to do it when we emit the Id itself
151 interestingId id = isId id && isLocalId id
155 %************************************************************************
157 \subsection{Completing an interface}
159 %************************************************************************
162 completeIface :: Maybe ModIface -- The old interface, if we have it
163 -> ModIface -- The new one, minus the decls and versions
164 -> ModDetails -- The ModDetails for this module
165 -> (ModIface, Maybe SDoc) -- The new one, complete with decls and versions
166 -- The SDoc is a debug document giving differences
167 -- Nothing => no change
169 -- NB: 'Nothing' means that even the usages havn't changed, so there's no
170 -- need to write a new interface file. But even if the usages have
171 -- changed, the module version may not have.
172 completeIface maybe_old_iface new_iface mod_details
173 = addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls })
175 new_decls = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls
176 inst_dcls = map ifaceInstance (md_insts mod_details)
177 ty_cls_dcls = foldNameEnv ifaceTyCls [] (md_types mod_details)
178 rule_dcls = map ifaceRule (md_rules mod_details)
183 ifaceTyCls :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
184 ifaceTyCls (AClass clas) so_far
187 cls_decl = ClassDecl { tcdCtxt = toHsContext sc_theta,
188 tcdName = getName clas,
189 tcdTyVars = toHsTyVars clas_tyvars,
190 tcdFDs = toHsFDs clas_fds,
191 tcdSigs = map toClassOpSig op_stuff,
193 tcdSysNames = sys_names,
196 (clas_tyvars, clas_fds, sc_theta, sc_sels, op_stuff) = classExtraBigSig clas
197 tycon = classTyCon clas
198 data_con = head (tyConDataCons tycon)
199 sys_names = mkClassDeclSysNames (getName tycon, getName data_con,
200 getName (dataConId data_con), map getName sc_sels)
202 toClassOpSig (sel_id, def_meth)
203 = ASSERT(sel_tyvars == clas_tyvars)
204 ClassOpSig (getName sel_id) def_meth' (toHsType op_ty) noSrcLoc
206 (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
207 def_meth' = case def_meth of
208 NoDefMeth -> NoDefMeth
209 GenDefMeth -> GenDefMeth
210 DefMeth id -> DefMeth (getName id)
212 ifaceTyCls (ATyCon tycon) so_far
213 | isClassTyCon tycon = so_far
214 | otherwise = ty_decl : so_far
216 ty_decl | isSynTyCon tycon
217 = TySynonym { tcdName = getName tycon,
218 tcdTyVars = toHsTyVars tyvars,
219 tcdSynRhs = toHsType syn_ty,
223 = TyData { tcdND = new_or_data,
224 tcdCtxt = toHsContext (tyConTheta tycon),
225 tcdName = getName tycon,
226 tcdTyVars = toHsTyVars tyvars,
227 tcdCons = map ifaceConDecl (tyConDataCons tycon),
228 tcdNCons = tyConFamilySize tycon,
230 tcdSysNames = map getName (tyConGenIds tycon),
233 | otherwise = pprPanic "ifaceTyCls" (ppr tycon)
235 tyvars = tyConTyVars tycon
236 (_, syn_ty) = getSynTyConDefn tycon
237 new_or_data | isNewTyCon tycon = NewType
238 | otherwise = DataType
240 ifaceConDecl data_con
241 = ConDecl (getName data_con) (getName (dataConId data_con))
242 (toHsTyVars ex_tyvars)
243 (toHsContext ex_theta)
246 (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
247 field_labels = dataConFieldLabels data_con
248 strict_marks = dataConStrictMarks data_con
249 details | null field_labels
250 = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
251 VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)
254 = RecCon (zipWith mk_field strict_marks field_labels)
256 mk_bang_ty NotMarkedStrict ty = Unbanged (toHsType ty)
257 mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
258 mk_bang_ty MarkedStrict ty = Banged (toHsType ty)
260 mk_field strict_mark field_label
261 = ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
263 ifaceTyCls (AnId id) so_far
264 | isImplicitId id = so_far
265 | otherwise = iface_sig : so_far
267 iface_sig = IfaceSig { tcdName = getName id,
268 tcdType = toHsType id_type,
269 tcdIdInfo = hs_idinfo,
275 hs_idinfo | opt_OmitInterfacePragmas = []
276 | otherwise = arity_hsinfo ++ caf_hsinfo ++ cpr_hsinfo ++
277 strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
279 ------------ Arity --------------
280 arity_hsinfo = case arityInfo id_info of
281 a@(ArityExactly n) -> [HsArity a]
284 ------------ Caf Info --------------
285 caf_hsinfo = case cafInfo id_info of
286 NoCafRefs -> [HsNoCafRefs]
289 ------------ CPR Info --------------
290 cpr_hsinfo = case cprInfo id_info of
291 ReturnsCPR -> [HsCprInfo]
294 ------------ Strictness --------------
295 strict_hsinfo = case strictnessInfo id_info of
296 NoStrictnessInfo -> []
297 info -> [HsStrictness info]
299 ------------ Worker --------------
300 work_info = workerInfo id_info
301 has_worker = case work_info of { HasWorker _ _ -> True; other -> False }
302 wrkr_hsinfo = case work_info of
303 HasWorker work_id wrap_arity -> [HsWorker (getName work_id)]
306 ------------ Unfolding --------------
307 -- The unfolding is redundant if there is a worker
308 unfold_info = unfoldingInfo id_info
309 inline_prag = inlinePragInfo id_info
310 rhs = unfoldingTemplate unfold_info
311 unfold_hsinfo | neverUnfold unfold_info
313 | otherwise = [HsUnfold inline_prag (toUfExpr rhs)]
317 ifaceInstance :: DFunId -> RenamedInstDecl
318 ifaceInstance dfun_id
319 = InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (getName dfun_id)) noSrcLoc
321 tidy_ty = tidyTopType (deNoteType (idType dfun_id))
322 -- The deNoteType is very important. It removes all type
323 -- synonyms from the instance type in interface files.
324 -- That in turn makes sure that when reading in instance decls
325 -- from interface files that the 'gating' mechanism works properly.
326 -- Otherwise you could have
327 -- type Tibble = T Int
328 -- instance Foo Tibble where ...
329 -- and this instance decl wouldn't get imported into a module
330 -- that mentioned T but not Tibble.
332 ifaceRule (id, BuiltinRule _)
333 = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id)
335 ifaceRule (id, Rule name bndrs args rhs)
336 = IfaceRule name (map toUfBndr bndrs) (getName id)
337 (map toUfExpr args) (toUfExpr rhs) noSrcLoc
340 = IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc
344 %************************************************************************
346 \subsection{Checking if the new interface is up to date
348 %************************************************************************
351 addVersionInfo :: Maybe ModIface -- The old interface, read from M.hi
352 -> ModIface -- The new interface decls
353 -> (ModIface, Maybe SDoc) -- Nothing => no change; no need to write new Iface
354 -- Just mi => Here is the new interface to write
355 -- with correct version numbers
357 -- NB: the fixities, declarations, rules are all assumed
358 -- to be sorted by increasing order of hsDeclName, so that
359 -- we can compare for equality
361 addVersionInfo Nothing new_iface
362 -- No old interface, so definitely write a new one!
363 = (new_iface, Just (text "No old interface available"))
365 addVersionInfo (Just old_iface@(ModIface { mi_version = old_version,
366 mi_decls = old_decls,
367 mi_fixities = old_fixities }))
368 new_iface@(ModIface { mi_decls = new_decls,
369 mi_fixities = new_fixities })
371 | no_output_change && no_usage_change
372 = (new_iface, Nothing)
373 -- don't return the old iface because it may not have an
374 -- mi_globals field set to anything reasonable.
376 | otherwise -- Add updated version numbers
377 = --pprTrace "completeIface" (ppr (dcl_tycl old_decls))
378 (final_iface, Just pp_diffs)
381 final_iface = new_iface { mi_version = new_version }
382 new_version = VersionInfo { vers_module = bumpVersion no_output_change (vers_module old_version),
383 vers_exports = bumpVersion no_export_change (vers_exports old_version),
384 vers_rules = bumpVersion no_rule_change (vers_rules old_version),
385 vers_decls = tc_vers }
387 no_output_change = no_tc_change && no_rule_change && no_export_change
388 no_usage_change = mi_usages old_iface == mi_usages new_iface
390 no_export_change = mi_exports old_iface == mi_exports new_iface -- Kept sorted
391 no_rule_change = dcl_rules old_decls == dcl_rules new_decls -- Ditto
393 -- Fill in the version number on the new declarations by looking at the old declarations.
394 -- Set the flag if anything changes.
395 -- Assumes that the decls are sorted by hsDeclName.
396 old_vers_decls = vers_decls old_version
397 (no_tc_change, pp_tc_diffs, tc_vers) = diffDecls old_vers_decls old_fixities new_fixities
398 (dcl_tycl old_decls) (dcl_tycl new_decls)
399 pp_diffs = vcat [pp_tc_diffs,
400 pp_change no_export_change "Export list",
401 pp_change no_rule_change "Rules",
402 pp_change no_usage_change "Usages"]
403 pp_change True what = empty
404 pp_change False what = text what <+> ptext SLIT("changed")
406 diffDecls :: NameEnv Version -- Old version map
407 -> NameEnv Fixity -> NameEnv Fixity -- Old and new fixities
408 -> [RenamedTyClDecl] -> [RenamedTyClDecl] -- Old and new decls
409 -> (Bool, -- True <=> no change
410 SDoc, -- Record of differences
411 NameEnv Version) -- New version
413 diffDecls old_vers old_fixities new_fixities old new
414 = diff True empty emptyNameEnv old new
416 -- When seeing if two decls are the same,
417 -- remember to check whether any relevant fixity has changed
418 eq_tc d1 d2 = d1 == d2 && all (same_fixity . fst) (tyClDeclNames d1)
419 same_fixity n = lookupNameEnv old_fixities n == lookupNameEnv new_fixities n
421 diff ok_so_far pp new_vers [] [] = (ok_so_far, pp, new_vers)
422 diff ok_so_far pp new_vers (od:ods) [] = diff False (pp $$ only_old od) new_vers ods []
423 diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers [] nds
424 diff ok_so_far pp new_vers (od:ods) (nd:nds)
425 = case od_name `compare` nd_name of
426 LT -> diff False (pp $$ only_old od) new_vers ods (nd:nds)
427 GT -> diff False (pp $$ only_new nd) new_vers (od:ods) nds
428 EQ | od `eq_tc` nd -> diff ok_so_far pp new_vers ods nds
429 | otherwise -> diff False (pp $$ changed od nd) new_vers' ods nds
431 od_name = tyClDeclName od
432 nd_name = tyClDeclName nd
433 new_vers' = extendNameEnv new_vers nd_name
434 (bumpVersion False (lookupNameEnv_NF old_vers od_name))
436 only_old d = ptext SLIT("Only in old iface:") <+> ppr d
437 only_new d = ptext SLIT("Only in new iface:") <+> ppr d
438 changed od nd = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr od) $$
439 (ptext SLIT("New:") <+> ppr nd))
444 %************************************************************************
446 \subsection{Writing an interface file}
448 %************************************************************************
451 writeIface :: FilePath -> ModIface -> IO ()
452 writeIface hi_path mod_iface
453 = do { if_hdl <- openFile hi_path WriteMode
454 ; printForIface if_hdl from_this_mod (pprIface mod_iface)
458 -- Print names unqualified if they are from this module
459 from_this_mod n = nameModule n == this_mod
460 this_mod = mi_module mod_iface
462 pprIface :: ModIface -> SDoc
464 = vcat [ ptext SLIT("__interface")
465 <+> doubleQuotes (ptext opt_InPackage)
466 <+> ppr (mi_module iface) <+> ppr (vers_module version_info)
468 <+> (if mi_orphan iface then char '!' else empty)
469 <+> int opt_HiVersion
470 <+> ptext SLIT("where")
472 , vcat (map pprExport (mi_exports iface))
473 , vcat (map pprUsage (mi_usages iface))
475 , pprFixities (mi_fixities iface) (dcl_tycl decls)
476 , pprIfaceDecls (vers_decls version_info) decls
477 , pprDeprecs (mi_deprecs iface)
480 version_info = mi_version iface
481 decls = mi_decls iface
482 exp_vers = vers_exports version_info
483 rule_vers = vers_rules version_info
485 pp_sub_vers | exp_vers == initialVersion && rule_vers == initialVersion = empty
486 | otherwise = brackets (ppr exp_vers <+> ppr rule_vers)
489 When printing export lists, we print like this:
491 AvailTC C [C, x, y] C(x,y)
492 AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C
495 pprExport :: (ModuleName, Avails) -> SDoc
496 pprExport (mod, items)
497 = hsep [ ptext SLIT("__export "), ppr mod, hsep (map pp_avail items) ] <> semi
499 pp_avail :: AvailInfo -> SDoc
500 pp_avail (Avail name) = pprOcc name
501 pp_avail (AvailTC n []) = empty
502 pp_avail (AvailTC n (n':ns)) | n==n' = pprOcc n <> pp_export ns
503 | otherwise = pprOcc n <> char '|' <> pp_export (n':ns)
506 pp_export names = braces (hsep (map pprOcc names))
508 pprOcc :: Name -> SDoc -- Print the occurrence name only
509 pprOcc n = pprOccName (nameOccName n)
514 pprUsage :: ImportVersion Name -> SDoc
515 pprUsage (m, has_orphans, is_boot, whats_imported)
516 = hsep [ptext SLIT("import"), ppr m,
518 pp_versions whats_imported
521 pp_orphan | has_orphans = char '!'
523 pp_boot | is_boot = char '@'
526 -- Importing the whole module is indicated by an empty list
527 pp_versions NothingAtAll = empty
528 pp_versions (Everything v) = dcolon <+> int v
529 pp_versions (Specifically vm ve nvs vr) = dcolon <+> int vm <+> pp_export_version ve <+> int vr
530 <+> hsep [ pprOcc n <+> int v | (n,v) <- nvs ]
532 pp_export_version Nothing = empty
533 pp_export_version (Just v) = int v
537 pprIfaceDecls version_map decls
538 = vcat [ vcat [ppr i <+> semi | i <- dcl_insts decls]
539 , vcat (map ppr_decl (dcl_tycl decls))
540 , pprRules (dcl_rules decls)
543 ppr_decl d = ppr_vers d <+> ppr d <> semi
545 -- Print the version for the decl
546 ppr_vers d = case lookupNameEnv version_map (tyClDeclName d) of
552 pprFixities fixity_map decls
553 = hsep [ ppr fix <+> ppr n
555 (n,_) <- tyClDeclNames d,
556 Just fix <- [lookupNameEnv fixity_map n]] <> semi
559 pprRules rules = hsep [ptext SLIT("{-## __R"), vcat (map ppr rules), ptext SLIT("##-}")]
561 pprDeprecs NoDeprecs = empty
562 pprDeprecs deprecs = ptext SLIT("{-## __D") <+> guts <+> ptext SLIT("##-}")
564 guts = case deprecs of
565 DeprecAll txt -> doubleQuotes (ptext txt)
566 DeprecSome env -> pp_deprecs env
568 pp_deprecs env = vcat (punctuate semi (map pp_deprec (nameEnvElts env)))
570 pp_deprec (name, txt) = pprOcc name <+> doubleQuotes (ptext txt)