2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
4 \section[MkIface]{Print an interface for a module}
7 #include "HsVersions.h"
9 module MkIface ( mkInterface ) where
11 import PrelInfo ( mkLiftTy, pRELUDE_BUILTIN )
12 import HsSyn ( FixityDecl(..), RenamedFixityDecl(..), MonoBinds,
13 RenamedMonoBinds(..), Name, RenamedPat(..), Sig
19 import IdInfo -- plenty from here
20 import Maybes ( catMaybes, Maybe(..) )
24 import TcInstDcls ( InstInfo(..) )
28 %************************************************************************
30 \subsection[main-MkIface]{Main routine for making interfaces}
32 %************************************************************************
37 We get the general what-to-export information from the ``environments''
38 produced by the typechecker (the \tr{[RenamedFixityDecl]} through
39 \tr{Bag InstInfo} arguments).
42 {\em However:} Whereas (for example) an \tr{InstInfo} will have
43 \tr{Ids} in it that identify the constant methods for that instance,
44 those particular \tr{Ids} {\em do not have} the best @IdInfos@!!!
45 Those @IdInfos@ were figured out long after the \tr{InstInfo} was
48 That's why we actually look at the final \tr{StgBindings} that go
49 into the code-generator: they have the best @IdInfos@ on them.
50 Whenever, we are about to print info about an @Id@, we look in the
51 Ids-from-STG-bindings list to see if we have an ``equivalent'' @Id@
52 with presumably-better @IdInfo@.
55 We play this same game whether for values, classes (for their
56 method-selectors and default-methods), or instances (for their
57 @DictFunIds@ or constant-methods).
59 Of course, for imported things, what we got from the typechecker is
63 We {\em sort} things in the interface into some ``canonical'' order;
64 otherwise, with heavily-recursive modules, you can have (unchanged)
65 information ``move around'' in the interface file---deeply unfriendly
70 mkInterface :: FAST_STRING
71 -> (FAST_STRING -> Bool, -- is something in export list, explicitly?
72 FAST_STRING -> Bool) -- is a module among the "dotdot" exported modules?
73 -> IdEnv UnfoldingDetails
74 -> FiniteMap TyCon [(Bool, [Maybe Type])]
75 -> ([RenamedFixityDecl], -- interface info from the typecheck
83 mkInterface modname export_list_fns inline_env tycon_specs
84 (fixity_decls, global_ids, ce, tce, inst_infos)
87 -- first, gather up the things we want to export:
89 exported_tycons = [ tc | tc <- rngTCE tce,
91 is_exportable_tycon_or_class export_list_fns tc ]
92 exported_classes = [ c | c <- rngCE ce,
94 is_exportable_tycon_or_class export_list_fns c ]
95 exported_inst_infos = [ i | i <- bagToList inst_infos,
96 is_exported_inst_info export_list_fns i ]
98 = [ v | v <- global_ids,
99 isExported v && not (isDataCon v) && not (isClassOpId v) ]
101 -- We also have to worry about TyCons/Classes that are
102 -- *mentioned* in exported things (e.g., values' types or
103 -- instances), so that we can be sure to do an import decl for
104 -- them, for original-naming purposes:
106 (mentioned_tycons, mentioned_classes)
107 = foldr ( \ (tcs1, cls1) (tcs2, cls2)
108 -> (tcs1 `unionBags` tcs2, cls1 `unionBags` cls2) )
110 (map getMentionedTyConsAndClassesFromClass exported_classes ++
111 map getMentionedTyConsAndClassesFromTyCon exported_tycons ++
112 map getMentionedTyConsAndClassesFromId exported_vals ++
113 map getMentionedTyConsAndClassesFromInstInfo exported_inst_infos)
116 = filter is_mentionable (bagToList mentioned_classes)
118 = [ tc | tc <- bagToList mentioned_tycons,
120 not (isPrimTyCon tc) ]
122 nondup_mentioned_tycons = fst (removeDups cmp mentionable_tycons)
123 nondup_mentioned_classes = fst (removeDups cmp mentionable_classes)
125 -- Next: as discussed in the notes, we want the top-level
126 -- Ids straight from the final STG code, so we can use
127 -- their IdInfos to print pragmas; we slurp them out here,
128 -- then pass them to the printing functions, which may
131 better_ids = collectExportedStgBinders stg_binds
133 -- Make a lookup function for convenient access:
136 = if not (isLocallyDefined i)
137 then i -- can't be among our "better_ids"
140 eq_fn = if isTopLevId i -- can't trust uniqs
141 then (\ x y -> origName x == origName y)
144 case [ x | x <- better_ids, x `eq_fn` i ] of
145 [] -> pprPanic "better_id_fn:" (ppr PprShowAll i)
148 _ -> panic "better_id_fn"
150 -- Finally, we sort everything lexically, so that we always
151 -- get the same interface from the same information:
153 sorted_mentioned_tycons = sortLt ltLexical nondup_mentioned_tycons
154 sorted_mentioned_classes = sortLt ltLexical nondup_mentioned_classes
156 sorted_tycons = sortLt ltLexical exported_tycons
157 sorted_classes = sortLt ltLexical exported_classes
158 sorted_vals = sortLt ltLexical exported_vals
159 sorted_inst_infos = sortLt lt_lexical_inst_info exported_inst_infos
161 if (any_purely_local sorted_tycons sorted_classes sorted_vals) then
162 -- this will be less of a HACK when we teach
163 -- mkInterface to do I/O (WDP 94/10)
164 error "Can't produce interface file because of errors!\n"
167 [ppPStr SLIT("{-# GHC_PRAGMA INTERFACE VERSION 7 #-}"),
168 ppCat [ppPStr SLIT("interface"), ppPStr modname, ppPStr SLIT("where")],
170 do_import_decls modname
171 sorted_vals sorted_mentioned_classes sorted_mentioned_tycons,
172 -- Mustn't give the data constructors to do_import_decls,
173 -- because they aren't explicitly imported; their tycon is.
175 ppAboves (map do_fixity fixity_decls),
176 ppAboves (map (pprIfaceClass better_id_fn inline_env) sorted_classes),
177 ppAboves (map (do_tycon tycon_specs) sorted_tycons),
178 ppAboves (map (do_value better_id_fn inline_env) sorted_vals),
179 ppAboves (map (do_instance better_id_fn inline_env) sorted_inst_infos),
184 any_purely_local tycons classes vals
185 = any bad_tc tycons || any bad_cl classes || any bad_id vals
188 = case (maybePurelyLocalClass cl) of
190 Just xs -> naughty_trace cl xs
193 = case (maybePurelyLocalType (idType id)) of
195 Just xs -> naughty_trace id xs
198 = case (maybePurelyLocalTyCon tc) of
200 Just xs -> if exported_abs then False else naughty_trace tc xs
202 exported_abs = case (getExportFlag tc) of { ExportAbs -> True; _ -> False }
204 naughty_trace x things
205 = pprTrace "Can't export -- `"
206 (ppBesides [ppr PprForUser x, ppStr "' mentions purely local things: ",
207 ppInterleave pp'SP things])
211 %************************************************************************
213 \subsection[imports-MkIface]{Generating `import' declarations in an interface}
215 %************************************************************************
217 We gather up lots of (module, name) pairs for which we might print an
218 import declaration. We sort them, for the usual canonicalisation
219 reasons. NB: We {\em assume} the lists passed in don't have duplicates in
222 All rather horribly turgid (WDP).
227 -> [Id] -> [Class] -> [TyCon]
230 do_import_decls mod_name vals classes tycons
232 -- Conjure up (module, name) pairs for all
233 -- the potentially import-decls things:
235 vals_names, classes_names, tycons_names :: [(FAST_STRING, FAST_STRING, [Maybe FAST_STRING])]
236 vals_names = map get_val_pair vals
237 classes_names = map get_class_pair classes
238 tycons_names = map get_tycon_pair tycons
240 -- sort the (module, name) pairs and chop
241 -- them into per-module groups:
243 ie_list = sortLt lt (tycons_names ++ classes_names ++ vals_names)
245 per_module_groups = runs same_module ie_list
247 ppAboves (map print_a_decl per_module_groups)
249 lt, same_module :: (FAST_STRING, FAST_STRING)
250 -> (FAST_STRING, FAST_STRING) -> Bool
253 = case (_CMP_STRING_ m1 m2) of { LT_ -> True; EQ_ -> ie1 < ie2; GT__ -> False }
255 same_module (m1, _, _) (m2, _, _) = m1 == m2
257 compiling_the_prelude = opt_CompilingPrelude
259 print_a_decl :: [(FAST_STRING, FAST_STRING, [Maybe FAST_STRING])] -> Pretty
261 Obviously, if the module in question is this one,
262 don't print an import declaration.
264 If it's a Prelude* module, we don't print the TyCons/
265 Classes, because the compiler supposedly knows about
266 them already (and they are PreludeCore things anyway).
268 But if we are compiling a Prelude module, then we
269 try to do it as "normally" as possible.
271 print_a_decl (ielist@((m,_,_) : _))
273 || (not compiling_the_prelude &&
274 ({-OLD:m == pRELUDE_CORE ||-} m == pRELUDE_BUILTIN))
278 = ppBesides [ppPStr SLIT("import "), ppPStr m, ppLparen,
279 ppIntersperse pp'SP{-'-} (map pp_str [n | (_,n,_) <- ielist]),
283 isnt_tycon_ish :: FAST_STRING -> Bool
284 isnt_tycon_ish str = not (isLexCon str)
286 grab_non_Nothings :: [[Maybe FAST_STRING]] -> [FAST_STRING]
288 grab_non_Nothings rns = catMaybes (concat rns)
290 pp_str :: FAST_STRING -> Pretty
292 = if isLexVarSym pstr then ppStr ("("++str++")") else ppPStr pstr
298 get_val_pair :: Id -> (FAST_STRING, FAST_STRING)
299 get_class_pair :: Class -> (FAST_STRING, FAST_STRING)
300 get_tycon_pair :: TyCon -> (FAST_STRING, FAST_STRING)
306 = case (generic_pair clas) of { (orig_mod, orig_nm) ->
308 nm_to_print = case (getExportFlag clas) of
309 ExportAll -> orig_nm _APPEND_ SLIT("(..)") -- nothing like a good HACK!
311 NotExported -> orig_nm
313 (orig_mod, nm_to_print) }
316 = case (generic_pair tycon) of { (orig_mod, orig_nm) ->
318 nm_to_print = case (getExportFlag tycon) of
319 ExportAll -> orig_nm _APPEND_ SLIT("(..)") -- nothing like a good HACK!
321 NotExported -> orig_nm
323 cons = tyConDataCons tycon
325 (orig_mod, nm_to_print) }
328 = case (moduleNamePair thing) of { (orig_mod, orig_nm) ->
329 case (getOccName thing) of { occur_name ->
330 (orig_mod, orig_nm) }}
333 %************************************************************************
335 \subsection[fixities-MkIface]{Generating fixity declarations in an interface}
337 %************************************************************************
341 do_fixity :: -> RenamedFixityDecl -> Pretty
343 do_fixity fixity_decl
344 = case (isLocallyDefined name, getExportFlag name) of
345 (True, ExportAll) -> ppr PprInterface fixity_decl
348 name = get_name fixity_decl
349 get_name (InfixL n _) = n
350 get_name (InfixR n _) = n
351 get_name (InfixN n _) = n
354 %************************************************************************
356 \subsection[tycons-MkIface]{Generating tycon declarations in an interface}
358 %************************************************************************
361 do_tycon :: FiniteMap TyCon [(Bool, [Maybe Type])] -> TyCon -> Pretty
363 do_tycon tycon_specs_map tycon
364 = pprTyCon PprInterface tycon tycon_specs
366 tycon_specs = map snd (lookupWithDefaultFM tycon_specs_map [] tycon)
369 %************************************************************************
371 \subsection[values-MkIface]{Generating a value's signature in an interface}
373 %************************************************************************
376 do_value :: (Id -> Id)
377 -> IdEnv UnfoldingDetails
381 do_value better_id_fn inline_env val
384 better_val = better_id_fn val
385 name_str = getOccName better_val -- NB: not orig name!
387 id_info = getIdInfo better_val
391 final_ty = idType better_val
393 -- ASSERT (orig_ty == final_ty || mkLiftTy orig_ty == final_ty)
394 ASSERT (if (orig_ty == final_ty || mkLiftTy orig_ty == final_ty) then True else pprTrace "do_value:" (ppCat [ppr PprDebug val, ppr PprDebug better_val]) False)
397 -- Note: We export the type of the original val
398 -- The type of an unboxed val will have been *lifted* by the desugarer
399 -- In this case we export an unlifted type, but id_info which assumes
400 -- a lifted Id i.e. extracted from better_val (above)
401 -- The importing module must lift the Id before using the imported id_info
404 = if opt_OmitInterfacePragmas
405 || boringIdInfo id_info
407 else ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"),
408 ppIdInfo sty better_val True{-yes specs-}
409 better_id_fn inline_env id_info,
412 ppAbove (ppCat [ppr_non_op name_str,
413 ppPStr SLIT("::"), pprGenType sty val_ty])
416 -- sadly duplicates Name.pprNonSym (ToDo)
419 = if isLexVarSym str -- NOT NEEDED: || isAconop
420 then ppBesides [ppLparen, ppPStr str, ppRparen]
424 %************************************************************************
426 \subsection[instances-MkIface]{Generating instance declarations in an interface}
428 %************************************************************************
430 The types of ``dictionary functions'' (dfuns) have just the required
431 info for instance declarations in interfaces. However, the dfuns that
432 GHC really uses have {\em extra} dictionaries passed to them (for
433 efficiency). When we print interfaces, we want to omit that
434 dictionary information. (It can be reconsituted on the other end,
435 from instance and class decls).
438 do_instance :: (Id -> Id)
439 -> IdEnv UnfoldingDetails
443 do_instance better_id_fn inline_env
444 (InstInfo clas tv_tmpls ty inst_decl_theta dfun_theta dfun_id constm_ids _ from_here modname _ _)
448 better_dfun = better_id_fn dfun_id
449 better_dfun_info = getIdInfo better_dfun
450 better_constms = map better_id_fn constm_ids
452 class_op_strs = map getClassOpString (getClassOps clas)
455 = ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"), pp_modname, ppPStr SLIT("{-dfun-}"),
456 ppIdInfo sty better_dfun False{-NO specs-}
457 better_id_fn inline_env better_dfun_info]
459 pragma_end = ppPStr SLIT("#-}")
461 pp_modname = if _NULL_ modname
463 else ppCat [ppStr "_M_", ppPStr modname]
466 = pp_the_list [ ppCat [ppChar '\t', ppr_non_op op, ppEquals,
468 ppIdInfo sty constm True{-YES, specs-}
469 better_id_fn inline_env
472 | (op, constm) <- class_op_strs `zip` better_constms ]
475 pp_the_list [] = panic "MkIface: no class_ops or better_constms?"
478 pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
481 = ppCat [ppPStr SLIT("instance"),
482 ppr sty (mkSigmaTy tv_tmpls inst_decl_theta (mkDictTy clas ty))]
484 if opt_OmitInterfacePragmas
485 || boringIdInfo better_dfun_info
487 else ppAbove real_stuff
488 ({-ppNest 8 -} -- ppNest does nothing
489 if null better_constms
490 then ppCat [pragma_begin, pragma_end]
491 else ppAbove pragma_begin (ppCat [name_pragma_pairs, pragma_end])
495 %************************************************************************
497 \subsection[utils-InstInfos]{Utility functions for @InstInfos@}
499 %************************************************************************
503 Classes/TyCons are ``known,'' more-or-less. Prelude TyCons are
504 ``completely'' known---they don't need to be mentioned in interfaces.
505 Classes usually don't need to be mentioned in interfaces, but if we're
506 compiling the prelude, then we treat them without special favours.
508 is_exportable_tycon_or_class export_list_fns tc
509 = if not (fromPreludeCore tc) then
512 in_export_list_or_among_dotdot_modules
513 opt_CompilingPrelude -- ignore M.. stuff if compiling prelude
516 in_export_list_or_among_dotdot_modules ignore_Mdotdots (in_export_list, among_dotdot_modules) tc
517 = if in_export_list (getOccName tc) then
520 -- pprTrace "in_export:" (ppAbove (ppr PprDebug ignore_Mdotdots) (ppPStr (getOccName tc))) (
521 if ignore_Mdotdots then
524 any among_dotdot_modules (getInformingModules tc)
528 = not (from_PreludeCore_or_Builtin tc) || opt_CompilingPrelude
530 from_PreludeCore_or_Builtin thing
532 mod_name = fst (moduleNamePair thing)
534 mod_name == pRELUDE_CORE || mod_name == pRELUDE_BUILTIN
536 is_exported_inst_info export_list_fns
537 (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
539 seems_exported = instanceIsExported clas ty from_here
540 (tycon, _, _) = getAppTyCon ty
542 if (opt_OmitReexportedInstances && not from_here) then
543 False -- Flag says to violate Haskell rules, blatantly
545 else if not opt_CompilingPrelude
546 || not (isFunTyCon tycon || fromPreludeCore tycon)
547 || not (fromPreludeCore clas) then
548 seems_exported -- take what we got
550 else -- compiling Prelude & tycon/class are Prelude things...
552 || in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns clas
553 || in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns tycon
557 lt_lexical_inst_info (InstInfo _ _ _ _ _ dfun1 _ _ _ _ _ _) (InstInfo _ _ _ _ _ dfun2 _ _ _ _ _ _)
558 = ltLexical dfun1 dfun2
562 getMentionedTyConsAndClassesFromInstInfo (InstInfo clas _ ty _ dfun_theta _ _ _ _ _ _ _)
563 = case (getMentionedTyConsAndClassesFromType ty) of { (ts, cs) ->
564 case [ c | (c, _) <- dfun_theta ] of { theta_classes ->
565 (ts, (cs `unionBags` listToBag theta_classes) `snocBag` clas)