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 (getExportFlag (get_name fixity_decl)) of
345 ExportAll -> ppr PprInterface fixity_decl
348 get_name (InfixL n _) = n
349 get_name (InfixR n _) = n
350 get_name (InfixN n _) = n
353 %************************************************************************
355 \subsection[tycons-MkIface]{Generating tycon declarations in an interface}
357 %************************************************************************
360 do_tycon :: FiniteMap TyCon [(Bool, [Maybe Type])] -> TyCon -> Pretty
362 do_tycon tycon_specs_map tycon
363 = pprTyCon PprInterface tycon tycon_specs
365 tycon_specs = map snd (lookupWithDefaultFM tycon_specs_map [] tycon)
368 %************************************************************************
370 \subsection[values-MkIface]{Generating a value's signature in an interface}
372 %************************************************************************
375 do_value :: (Id -> Id)
376 -> IdEnv UnfoldingDetails
380 do_value better_id_fn inline_env val
383 better_val = better_id_fn val
384 name_str = getOccName better_val -- NB: not orig name!
386 id_info = getIdInfo better_val
390 final_ty = idType better_val
392 -- ASSERT (orig_ty == final_ty || mkLiftTy orig_ty == final_ty)
393 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)
396 -- Note: We export the type of the original val
397 -- The type of an unboxed val will have been *lifted* by the desugarer
398 -- In this case we export an unlifted type, but id_info which assumes
399 -- a lifted Id i.e. extracted from better_val (above)
400 -- The importing module must lift the Id before using the imported id_info
403 = if opt_OmitInterfacePragmas
404 || boringIdInfo id_info
406 else ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"),
407 ppIdInfo sty better_val True{-yes specs-}
408 better_id_fn inline_env id_info,
411 ppAbove (ppCat [ppr_non_op name_str,
412 ppPStr SLIT("::"), pprGenType sty val_ty])
415 -- sadly duplicates Name.pprNonSym (ToDo)
418 = if isLexVarSym str -- NOT NEEDED: || isAconop
419 then ppBesides [ppLparen, ppPStr str, ppRparen]
423 %************************************************************************
425 \subsection[instances-MkIface]{Generating instance declarations in an interface}
427 %************************************************************************
429 The types of ``dictionary functions'' (dfuns) have just the required
430 info for instance declarations in interfaces. However, the dfuns that
431 GHC really uses have {\em extra} dictionaries passed to them (for
432 efficiency). When we print interfaces, we want to omit that
433 dictionary information. (It can be reconsituted on the other end,
434 from instance and class decls).
437 do_instance :: (Id -> Id)
438 -> IdEnv UnfoldingDetails
442 do_instance better_id_fn inline_env
443 (InstInfo clas tv_tmpls ty inst_decl_theta dfun_theta dfun_id constm_ids _ from_here modname _ _)
447 better_dfun = better_id_fn dfun_id
448 better_dfun_info = getIdInfo better_dfun
449 better_constms = map better_id_fn constm_ids
451 class_op_strs = map getClassOpString (getClassOps clas)
454 = ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"), pp_modname, ppPStr SLIT("{-dfun-}"),
455 ppIdInfo sty better_dfun False{-NO specs-}
456 better_id_fn inline_env better_dfun_info]
458 pragma_end = ppPStr SLIT("#-}")
460 pp_modname = if _NULL_ modname
462 else ppCat [ppStr "_M_", ppPStr modname]
465 = pp_the_list [ ppCat [ppChar '\t', ppr_non_op op, ppEquals,
467 ppIdInfo sty constm True{-YES, specs-}
468 better_id_fn inline_env
471 | (op, constm) <- class_op_strs `zip` better_constms ]
474 pp_the_list [] = panic "MkIface: no class_ops or better_constms?"
477 pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
480 = ppCat [ppPStr SLIT("instance"),
481 ppr sty (mkSigmaTy tv_tmpls inst_decl_theta (mkDictTy clas ty))]
483 if opt_OmitInterfacePragmas
484 || boringIdInfo better_dfun_info
486 else ppAbove real_stuff
487 ({-ppNest 8 -} -- ppNest does nothing
488 if null better_constms
489 then ppCat [pragma_begin, pragma_end]
490 else ppAbove pragma_begin (ppCat [name_pragma_pairs, pragma_end])
494 %************************************************************************
496 \subsection[utils-InstInfos]{Utility functions for @InstInfos@}
498 %************************************************************************
502 Classes/TyCons are ``known,'' more-or-less. Prelude TyCons are
503 ``completely'' known---they don't need to be mentioned in interfaces.
504 Classes usually don't need to be mentioned in interfaces, but if we're
505 compiling the prelude, then we treat them without special favours.
507 is_exportable_tycon_or_class export_list_fns tc
508 = if not (fromPreludeCore tc) then
511 in_export_list_or_among_dotdot_modules
512 opt_CompilingPrelude -- ignore M.. stuff if compiling prelude
515 in_export_list_or_among_dotdot_modules ignore_Mdotdots (in_export_list, among_dotdot_modules) tc
516 = if in_export_list (getOccName tc) then
519 -- pprTrace "in_export:" (ppAbove (ppr PprDebug ignore_Mdotdots) (ppPStr (getOccName tc))) (
520 if ignore_Mdotdots then
523 any among_dotdot_modules (getInformingModules tc)
527 = not (from_PreludeCore_or_Builtin tc) || opt_CompilingPrelude
529 from_PreludeCore_or_Builtin thing
531 mod_name = fst (moduleNamePair thing)
533 mod_name == pRELUDE_CORE || mod_name == pRELUDE_BUILTIN
535 is_exported_inst_info export_list_fns
536 (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
538 seems_exported = instanceIsExported clas ty from_here
539 (tycon, _, _) = getAppTyCon ty
541 if (opt_OmitReexportedInstances && not from_here) then
542 False -- Flag says to violate Haskell rules, blatantly
544 else if not opt_CompilingPrelude
545 || not (isFunTyCon tycon || fromPreludeCore tycon)
546 || not (fromPreludeCore clas) then
547 seems_exported -- take what we got
549 else -- compiling Prelude & tycon/class are Prelude things...
551 || in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns clas
552 || in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns tycon
556 lt_lexical_inst_info (InstInfo _ _ _ _ _ dfun1 _ _ _ _ _ _) (InstInfo _ _ _ _ _ dfun2 _ _ _ _ _ _)
557 = ltLexical dfun1 dfun2
561 getMentionedTyConsAndClassesFromInstInfo (InstInfo clas _ ty _ dfun_theta _ _ _ _ _ _ _)
562 = case (getMentionedTyConsAndClassesFromType ty) of { (ts, cs) ->
563 case [ c | (c, _) <- dfun_theta ] of { theta_classes ->
564 (ts, (cs `unionBags` listToBag theta_classes) `snocBag` clas)