2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
4 \section[MkIface]{Print an interface for a module}
7 #include "HsVersions.h"
12 -- and to make the interface self-sufficient...
13 Bag, CE(..), GlobalSwitch, FixityDecl, Id,
14 Name, PrettyRep, StgBinding, TCE(..), UniqFM, InstInfo
17 IMPORT_Trace -- ToDo: rm (debugging)
19 import AbsPrel ( mkLiftTy, pRELUDE_CORE, pRELUDE_BUILTIN )
20 import AbsSyn ( FixityDecl(..), RenamedFixityDecl(..), MonoBinds,
21 RenamedMonoBinds(..), Name, RenamedPat(..), Sig
26 import CmdLineOpts -- ( GlobalSwitch(..) )
29 import IdInfo -- plenty from here
30 import Maybes ( catMaybes, Maybe(..) )
35 import TcInstDcls ( InstInfo(..) )
39 %************************************************************************
41 \subsection[main-MkIface]{Main routine for making interfaces}
43 %************************************************************************
48 We get the general what-to-export information from the ``environments''
49 produced by the typechecker (the \tr{[RenamedFixityDecl]} through
50 \tr{Bag InstInfo} arguments).
53 {\em However:} Whereas (for example) an \tr{InstInfo} will have
54 \tr{Ids} in it that identify the constant methods for that instance,
55 those particular \tr{Ids} {\em do not have} the best @IdInfos@!!!
56 Those @IdInfos@ were figured out long after the \tr{InstInfo} was
59 That's why we actually look at the final \tr{PlainStgBindings} that go
60 into the code-generator: they have the best @IdInfos@ on them.
61 Whenever, we are about to print info about an @Id@, we look in the
62 Ids-from-STG-bindings list to see if we have an ``equivalent'' @Id@
63 with presumably-better @IdInfo@.
66 We play this same game whether for values, classes (for their
67 method-selectors and default-methods), or instances (for their
68 @DictFunIds@ or constant-methods).
70 Of course, for imported things, what we got from the typechecker is
74 We {\em sort} things in the interface into some ``canonical'' order;
75 otherwise, with heavily-recursive modules, you can have (unchanged)
76 information ``move around'' in the interface file---deeply unfriendly
81 mkInterface :: (GlobalSwitch -> Bool)
83 -> (FAST_STRING -> Bool, -- is something in export list, explicitly?
84 FAST_STRING -> Bool) -- is a module among the "dotdot" exported modules?
85 -> IdEnv UnfoldingDetails
86 -> FiniteMap TyCon [[Maybe UniType]]
87 -> ([RenamedFixityDecl], -- interface info from the typecheck
95 mkInterface sw_chkr modname export_list_fns inline_env tycon_specs
96 (fixity_decls, global_ids, ce, tce, inst_infos)
99 -- first, gather up the things we want to export:
101 exported_tycons = [ tc | tc <- rngTCE tce,
103 is_exportable_tycon_or_class sw_chkr export_list_fns tc ]
104 exported_classes = [ c | c <- rngCE ce,
106 is_exportable_tycon_or_class sw_chkr export_list_fns c ]
107 exported_inst_infos = [ i | i <- bagToList inst_infos,
108 is_exported_inst_info sw_chkr export_list_fns i ]
110 = [ v | v <- global_ids,
111 isExported v && not (isDataCon v) && not (isClassOpId v) ]
113 -- We also have to worry about TyCons/Classes that are
114 -- *mentioned* in exported things (e.g., values' types or
115 -- instances), so that we can be sure to do an import decl for
116 -- them, for original-naming purposes:
118 (mentioned_tycons, mentioned_classes)
119 = foldr ( \ (tcs1, cls1) (tcs2, cls2)
120 -> (tcs1 `unionBags` tcs2, cls1 `unionBags` cls2) )
122 (map getMentionedTyConsAndClassesFromClass exported_classes ++
123 map getMentionedTyConsAndClassesFromTyCon exported_tycons ++
124 map getMentionedTyConsAndClassesFromId exported_vals ++
125 map getMentionedTyConsAndClassesFromInstInfo exported_inst_infos)
128 = filter (is_mentionable sw_chkr) (bagToList mentioned_classes)
130 = [ tc | tc <- bagToList mentioned_tycons,
131 is_mentionable sw_chkr tc,
132 not (isPrimTyCon tc) ]
134 nondup_mentioned_tycons = fst (removeDups cmpTyCon mentionable_tycons)
135 nondup_mentioned_classes = fst (removeDups cmpClass mentionable_classes)
137 -- Next: as discussed in the notes, we want the top-level
138 -- Ids straight from the final STG code, so we can use
139 -- their IdInfos to print pragmas; we slurp them out here,
140 -- then pass them to the printing functions, which may
143 better_ids = collectExportedStgBinders stg_binds
145 -- Make a lookup function for convenient access:
148 = if not (isLocallyDefined i)
149 then i -- can't be among our "better_ids"
152 eq_fn = if isTopLevId i -- can't trust uniqs
153 then (\ x y -> getOrigName x == getOrigName y)
156 case [ x | x <- better_ids, x `eq_fn` i ] of
157 [] -> pprPanic "better_id_fn:" (ppr PprShowAll i)
160 _ -> panic "better_id_fn"
162 -- Finally, we sort everything lexically, so that we always
163 -- get the same interface from the same information:
165 sorted_mentioned_tycons = sortLt ltLexical nondup_mentioned_tycons
166 sorted_mentioned_classes = sortLt ltLexical nondup_mentioned_classes
168 sorted_tycons = sortLt ltLexical exported_tycons
169 sorted_classes = sortLt ltLexical exported_classes
170 sorted_vals = sortLt ltLexical exported_vals
171 sorted_inst_infos = sortLt lt_lexical_inst_info exported_inst_infos
173 if (any_purely_local sorted_tycons sorted_classes sorted_vals) then
174 -- this will be less of a HACK when we teach
175 -- mkInterface to do I/O (WDP 94/10)
176 error "Can't produce interface file because of errors!\n"
178 -- trace ("mkIface:Ids:"++(ppShow 80 (ppr PprDebug global_ids))) (
180 [ppPStr SLIT("{-# GHC_PRAGMA INTERFACE VERSION 5 #-}"),
181 ppCat [ppPStr SLIT("interface"), ppPStr modname, ppPStr SLIT("where")],
183 do_import_decls sw_chkr modname
184 sorted_vals sorted_mentioned_classes sorted_mentioned_tycons,
185 -- Mustn't give the data constructors to do_import_decls,
186 -- because they aren't explicitly imported; their tycon is.
187 -- ToDo: modify if we ever add renaming properly.
189 ppAboves (map (do_fixity sw_chkr) fixity_decls),
190 ppAboves (map (pprIfaceClass sw_chkr better_id_fn inline_env) sorted_classes),
191 ppAboves (map (do_tycon sw_chkr tycon_specs) sorted_tycons),
192 ppAboves (map (do_value sw_chkr better_id_fn inline_env) sorted_vals),
193 ppAboves (map (do_instance sw_chkr better_id_fn inline_env) sorted_inst_infos),
199 any_purely_local tycons classes vals
200 = any bad_tc tycons || any bad_cl classes || any bad_id vals
203 = case (maybePurelyLocalClass cl) of
205 Just xs -> naughty_trace cl xs
208 = case (maybePurelyLocalType (getIdUniType id)) of
210 Just xs -> naughty_trace id xs
213 = case (maybePurelyLocalTyCon tc) of
215 Just xs -> if exported_abs then False else naughty_trace tc xs
217 exported_abs = case (getExportFlag tc) of { ExportAbs -> True; _ -> False }
219 naughty_trace x things
220 = pprTrace "Can't export -- `"
221 (ppBesides [ppr PprForUser x, ppStr "' mentions purely local things: ",
222 ppInterleave pp'SP things])
226 %************************************************************************
228 \subsection[imports-MkIface]{Generating `import' declarations in an interface}
230 %************************************************************************
232 Not handling renaming yet (ToDo)
234 We gather up lots of (module, name) pairs for which we might print an
235 import declaration. We sort them, for the usual canonicalisation
236 reasons. NB: We {\em assume} the lists passed in don't have duplicates in
239 All rather horribly turgid (WDP).
243 :: (GlobalSwitch -> Bool)
245 -> [Id] -> [Class] -> [TyCon]
248 do_import_decls sw_chkr mod_name vals classes tycons
250 -- Conjure up (module, name, maybe_renaming) triples for all
251 -- the potentially import-decls things:
253 vals_names, classes_names, tycons_names :: [(FAST_STRING, FAST_STRING, [Maybe FAST_STRING])]
254 vals_names = map get_val_triple vals
255 classes_names = map get_class_triple classes
256 tycons_names = map get_tycon_triple tycons
258 -- sort the (module, name, renaming) triples and chop
259 -- them into per-module groups:
261 ie_list = sortLt lt (tycons_names ++ classes_names ++ vals_names)
263 per_module_groups = runs same_module ie_list
265 ppAboves (map print_a_decl per_module_groups)
267 lt, same_module :: (FAST_STRING, FAST_STRING, [Maybe FAST_STRING])
268 -> (FAST_STRING, FAST_STRING, [Maybe FAST_STRING]) -> Bool
270 lt (m1, ie1, _) (m2, ie2, _)
271 = case _CMP_STRING_ m1 m2 of { LT_ -> True; EQ_ -> ie1 < ie2; GT__ -> False }
273 same_module (m1, _, _) (m2, _, _) = m1 == m2
275 compiling_the_prelude = sw_chkr CompilingPrelude
277 print_a_decl :: [(FAST_STRING, FAST_STRING, [Maybe FAST_STRING])] -> Pretty
279 Obviously, if the module in question is this one,
280 don't print an import declaration.
282 If it's a Prelude* module, we don't print the TyCons/
283 Classes, because the compiler supposedly knows about
284 them already (and they are PreludeCore things anyway).
286 But if we are compiling a Prelude module, then we
287 try to do it as "normally" as possible.
289 print_a_decl (ielist@((m,_,_) : _))
291 || (not compiling_the_prelude &&
292 (m == pRELUDE_CORE || m == pRELUDE_BUILTIN))
296 = ppBesides [ppPStr SLIT("import "), ppPStr m, ppLparen,
297 ppIntersperse pp'SP{-'-} (map pp_str [n | (_,n,_) <- ielist]),
299 case (grab_non_Nothings [rns | (_,_,rns) <- ielist]) of
301 renamings -> pp_renamings renamings
304 isnt_tycon_ish :: FAST_STRING -> Bool
305 isnt_tycon_ish str = not (isConop str)
307 grab_non_Nothings :: [[Maybe FAST_STRING]] -> [FAST_STRING]
309 grab_non_Nothings rns = catMaybes (concat rns)
311 pp_str :: FAST_STRING -> Pretty
313 = if isAvarop pstr then ppStr ("("++str++")") else ppPStr pstr
318 = ppBesides [ ppPStr SLIT(" renaming "), ppLparen, ppIntersperse pp'SP{-'-} (map ppPStr strs), ppRparen ]
321 Most of the huff and puff here is to ferret out renaming strings.
324 get_val_triple :: Id -> (FAST_STRING, FAST_STRING, [Maybe FAST_STRING])
325 get_class_triple :: Class -> (FAST_STRING, FAST_STRING, [Maybe FAST_STRING])
326 get_tycon_triple :: TyCon -> (FAST_STRING, FAST_STRING, [Maybe FAST_STRING])
329 = case (generic_triple id) of { (a,b,rn) ->
332 get_class_triple clas
333 = case (generic_triple clas) of { (orig_mod, orig_nm, clas_rn) ->
335 nm_to_print = case (getExportFlag clas) of
336 ExportAll -> orig_nm _APPEND_ SLIT("(..)") -- nothing like a good HACK!
338 NotExported -> orig_nm
340 -- Ops don't have renaming info (bug) ToDo
341 -- ops = getClassOps clas
342 -- ops_rns = [ rn | (_,_,rn) <- map generic_triple ops ]
344 (orig_mod, nm_to_print, [clas_rn]) }
346 get_tycon_triple tycon
347 = case (generic_triple tycon) of { (orig_mod, orig_nm, tycon_rn) ->
349 nm_to_print = case (getExportFlag tycon) of
350 ExportAll -> orig_nm _APPEND_ SLIT("(..)") -- nothing like a good HACK!
352 NotExported -> orig_nm
354 cons = getTyConDataCons tycon
355 cons_rns = [ rn | (_,_,rn) <- map generic_triple cons ]
357 (orig_mod, nm_to_print, tycon_rn : cons_rns) }
360 = case (getOrigName thing) of { (orig_mod, orig_nm) ->
361 case (getOccurrenceName thing) of { occur_name ->
363 if orig_nm == occur_name
365 else Just (orig_nm _APPEND_ SLIT(" to ") _APPEND_ occur_name)
369 %************************************************************************
371 \subsection[fixities-MkIface]{Generating fixity declarations in an interface}
373 %************************************************************************
377 do_fixity :: (GlobalSwitch -> Bool) -> RenamedFixityDecl -> Pretty
379 do_fixity sw_chkr fixity_decl
380 = case (getExportFlag (get_name fixity_decl)) of
381 ExportAll -> ppr (PprInterface sw_chkr) fixity_decl
384 get_name (InfixL n _) = n
385 get_name (InfixR n _) = n
386 get_name (InfixN n _) = n
389 %************************************************************************
391 \subsection[tycons-MkIface]{Generating tycon declarations in an interface}
393 %************************************************************************
396 do_tycon :: (GlobalSwitch -> Bool) -> FiniteMap TyCon [[Maybe UniType]] -> TyCon -> Pretty
398 do_tycon sw_chkr tycon_specs_map tycon
399 = pprTyCon (PprInterface sw_chkr) tycon tycon_specs
401 tycon_specs = lookupWithDefaultFM tycon_specs_map [] tycon
404 %************************************************************************
406 \subsection[values-MkIface]{Generating a value's signature in an interface}
408 %************************************************************************
411 do_value :: (GlobalSwitch -> Bool)
413 -> IdEnv UnfoldingDetails
417 do_value sw_chkr better_id_fn inline_env val
419 sty = PprInterface sw_chkr
420 better_val = better_id_fn val
421 name_str = getOccurrenceName better_val -- NB: not orig name!
423 id_info = getIdInfo better_val
426 orig_ty = getIdUniType val
427 final_ty = getIdUniType better_val
429 -- ASSERT (orig_ty == final_ty || mkLiftTy orig_ty == final_ty)
430 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)
433 -- Note: We export the type of the original val
434 -- The type of an unboxed val will have been *lifted* by the desugarer
435 -- In this case we export an unlifted type, but id_info which assumes
436 -- a lifted Id i.e. extracted from better_val (above)
437 -- The importing module must lift the Id before using the imported id_info
440 = if sw_chkr OmitInterfacePragmas
441 || boringIdInfo id_info
443 else ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"),
444 ppIdInfo sty better_val True{-specs, absolutely-}
445 better_id_fn inline_env id_info,
448 ppAbove (ppCat [ppr_non_op name_str,
449 ppPStr SLIT("::"), pprUniType sty val_ty])
452 -- sadly duplicates Outputable.pprNonOp (ToDo)
455 = if isAvarop str -- NOT NEEDED: || isAconop
456 then ppBesides [ppLparen, ppPStr str, ppRparen]
460 %************************************************************************
462 \subsection[instances-MkIface]{Generating instance declarations in an interface}
464 %************************************************************************
466 The types of ``dictionary functions'' (dfuns) have just the required
467 info for instance declarations in interfaces. However, the dfuns that
468 GHC really uses have {\em extra} dictionaries passed to them (for
469 efficiency). When we print interfaces, we want to omit that
470 dictionary information. (It can be reconsituted on the other end,
471 from instance and class decls).
474 do_instance :: (GlobalSwitch -> Bool)
476 -> IdEnv UnfoldingDetails
480 do_instance sw_chkr better_id_fn inline_env
481 (InstInfo clas tv_tmpls ty inst_decl_theta dfun_theta dfun_id constm_ids _ from_here modname _ _)
483 sty = PprInterface sw_chkr
485 better_dfun = better_id_fn dfun_id
486 better_dfun_info = getIdInfo better_dfun
487 better_constms = map better_id_fn constm_ids
489 class_op_strs = map getClassOpString (getClassOps clas)
492 = ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"), pp_modname, ppPStr SLIT("{-dfun-}"),
493 ppIdInfo sty better_dfun False{-NO specs-}
494 better_id_fn inline_env better_dfun_info]
496 pragma_end = ppPStr SLIT("#-}")
498 pp_modname = if _NULL_ modname
500 else ppCat [ppStr "_M_", ppPStr modname]
503 = pp_the_list [ ppCat [ppChar '\t', ppr_non_op op, ppEquals,
504 ppIdInfo sty constm True{-YES, specs-}
505 better_id_fn inline_env
507 | (op, constm) <- class_op_strs `zip` better_constms ]
510 pp_the_list [] = panic "MkIface: no class_ops or better_constms?"
513 pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
516 = ppCat [ppPStr SLIT("instance"),
517 ppr sty (mkSigmaTy tv_tmpls inst_decl_theta (mkDictTy clas ty))]
519 if sw_chkr OmitInterfacePragmas
520 || boringIdInfo better_dfun_info
522 else ppAbove real_stuff
523 ({-ppNest 8 -} -- ppNest does nothing
524 if null better_constms
525 then ppCat [pragma_begin, pragma_end]
526 else ppAbove pragma_begin (ppCat [name_pragma_pairs, pragma_end])
527 -- ToDo: specialised instances
531 %************************************************************************
533 \subsection[utils-InstInfos]{Utility functions for @InstInfos@}
535 %************************************************************************
539 Classes/TyCons are ``known,'' more-or-less. Prelude TyCons are
540 ``completely'' known---they don't need to be mentioned in interfaces.
541 Classes usually don't need to be mentioned in interfaces, but if we're
542 compiling the prelude, then we treat them without special favours.
544 is_exportable_tycon_or_class sw_chkr export_list_fns tc
545 = if not (fromPreludeCore tc) then
548 in_export_list_or_among_dotdot_modules
549 (sw_chkr CompilingPrelude) -- ignore M.. stuff if compiling prelude
552 in_export_list_or_among_dotdot_modules ignore_Mdotdots (in_export_list, among_dotdot_modules) tc
553 = if in_export_list (getOccurrenceName tc) then
556 -- pprTrace "in_export:" (ppAbove (ppr PprDebug ignore_Mdotdots) (ppPStr (getOccurrenceName tc))) (
557 if ignore_Mdotdots then
560 any among_dotdot_modules (getInformingModules tc)
563 is_mentionable sw_chkr tc
564 = not (from_PreludeCore_or_Builtin tc) || (sw_chkr CompilingPrelude)
566 from_PreludeCore_or_Builtin thing
568 mod_name = fst (getOrigName thing)
570 mod_name == pRELUDE_CORE || mod_name == pRELUDE_BUILTIN
572 is_exported_inst_info sw_chkr export_list_fns
573 (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
575 is_fun_tycon = isFunType ty
577 seems_exported = instanceIsExported clas ty from_here
579 (tycon, _, _) = getUniDataTyCon ty
581 if (sw_chkr OmitReexportedInstances && not from_here) then
582 False -- Flag says to violate Haskell rules, blatantly
584 else if not (sw_chkr CompilingPrelude)
585 || not (is_fun_tycon || fromPreludeCore tycon)
586 || not (fromPreludeCore clas) then
587 seems_exported -- take what we got
589 else -- compiling Prelude & tycon/class are Prelude things...
591 || in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns clas
593 && in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns tycon)
597 lt_lexical_inst_info (InstInfo _ _ _ _ _ dfun1 _ _ _ _ _ _) (InstInfo _ _ _ _ _ dfun2 _ _ _ _ _ _)
598 = ltLexical dfun1 dfun2
602 getMentionedTyConsAndClassesFromInstInfo (InstInfo clas _ ty _ dfun_theta _ _ _ _ _ _ _)
603 = case (getMentionedTyConsAndClassesFromUniType ty) of { (ts, cs) ->
604 case [ c | (c, _) <- dfun_theta ] of { theta_classes ->
605 (ts, (cs `unionBags` listToBag theta_classes) `snocBag` clas)