-mkInterface :: (GlobalSwitch -> Bool)
- -> FAST_STRING
- -> (FAST_STRING -> Bool, -- is something in export list, explicitly?
- FAST_STRING -> Bool) -- is a module among the "dotdot" exported modules?
- -> IdEnv UnfoldingDetails
- -> FiniteMap TyCon [[Maybe UniType]]
- -> ([RenamedFixityDecl], -- interface info from the typecheck
- [Id],
- CE,
- TCE,
- Bag InstInfo)
- -> [PlainStgBinding]
- -> Pretty
-
-mkInterface sw_chkr modname export_list_fns inline_env tycon_specs
- (fixity_decls, global_ids, ce, tce, inst_infos)
- stg_binds
- = let
- -- first, gather up the things we want to export:
-
- exported_tycons = [ tc | tc <- rngTCE tce,
- isExported tc,
- is_exportable_tycon_or_class sw_chkr export_list_fns tc ]
- exported_classes = [ c | c <- rngCE ce,
- isExported c,
- is_exportable_tycon_or_class sw_chkr export_list_fns c ]
- exported_inst_infos = [ i | i <- bagToList inst_infos,
- is_exported_inst_info sw_chkr export_list_fns i ]
- exported_vals
- = [ v | v <- global_ids,
- isExported v && not (isDataCon v) && not (isClassOpId v) ]
-
- -- We also have to worry about TyCons/Classes that are
- -- *mentioned* in exported things (e.g., values' types or
- -- instances), so that we can be sure to do an import decl for
- -- them, for original-naming purposes:
-
- (mentioned_tycons, mentioned_classes)
- = foldr ( \ (tcs1, cls1) (tcs2, cls2)
- -> (tcs1 `unionBags` tcs2, cls1 `unionBags` cls2) )
- (emptyBag, emptyBag)
- (map getMentionedTyConsAndClassesFromClass exported_classes ++
- map getMentionedTyConsAndClassesFromTyCon exported_tycons ++
- map getMentionedTyConsAndClassesFromId exported_vals ++
- map getMentionedTyConsAndClassesFromInstInfo exported_inst_infos)
-
- mentionable_classes
- = filter (is_mentionable sw_chkr) (bagToList mentioned_classes)
- mentionable_tycons
- = [ tc | tc <- bagToList mentioned_tycons,
- is_mentionable sw_chkr tc,
- not (isPrimTyCon tc) ]
-
- nondup_mentioned_tycons = fst (removeDups cmpTyCon mentionable_tycons)
- nondup_mentioned_classes = fst (removeDups cmpClass mentionable_classes)
-
- -- Next: as discussed in the notes, we want the top-level
- -- Ids straight from the final STG code, so we can use
- -- their IdInfos to print pragmas; we slurp them out here,
- -- then pass them to the printing functions, which may
- -- use them.
-
- better_ids = collectExportedStgBinders stg_binds
-
- -- Make a lookup function for convenient access:
-
- better_id_fn i
- = if not (isLocallyDefined i)
- then i -- can't be among our "better_ids"
- else
- let
- eq_fn = if isTopLevId i -- can't trust uniqs
- then (\ x y -> getOrigName x == getOrigName y)
- else eqId
- in
- case [ x | x <- better_ids, x `eq_fn` i ] of
- [] -> pprPanic "better_id_fn:" (ppr PprShowAll i)
- i
- [x] -> x
- _ -> panic "better_id_fn"
-
- -- Finally, we sort everything lexically, so that we always
- -- get the same interface from the same information:
-
- sorted_mentioned_tycons = sortLt ltLexical nondup_mentioned_tycons
- sorted_mentioned_classes = sortLt ltLexical nondup_mentioned_classes
-
- sorted_tycons = sortLt ltLexical exported_tycons
- sorted_classes = sortLt ltLexical exported_classes
- sorted_vals = sortLt ltLexical exported_vals
- sorted_inst_infos = sortLt lt_lexical_inst_info exported_inst_infos
- in
- if (any_purely_local sorted_tycons sorted_classes sorted_vals) then
- -- this will be less of a HACK when we teach
- -- mkInterface to do I/O (WDP 94/10)
- error "Can't produce interface file because of errors!\n"
- else
--- trace ("mkIface:Ids:"++(ppShow 80 (ppr PprDebug global_ids))) (
- ppAboves
- [ppPStr SLIT("{-# GHC_PRAGMA INTERFACE VERSION 5 #-}"),
- ppCat [ppPStr SLIT("interface"), ppPStr modname, ppPStr SLIT("where")],
-
- do_import_decls sw_chkr modname
- sorted_vals sorted_mentioned_classes sorted_mentioned_tycons,
- -- Mustn't give the data constructors to do_import_decls,
- -- because they aren't explicitly imported; their tycon is.
- -- ToDo: modify if we ever add renaming properly.
-
- ppAboves (map (do_fixity sw_chkr) fixity_decls),
- ppAboves (map (pprIfaceClass sw_chkr better_id_fn inline_env) sorted_classes),
- ppAboves (map (do_tycon sw_chkr tycon_specs) sorted_tycons),
- ppAboves (map (do_value sw_chkr better_id_fn inline_env) sorted_vals),
- ppAboves (map (do_instance sw_chkr better_id_fn inline_env) sorted_inst_infos),
-
- ppChar '\n'
- ]
--- )
- where
- any_purely_local tycons classes vals
- = any bad_tc tycons || any bad_cl classes || any bad_id vals
- where
- bad_cl cl
- = case (maybePurelyLocalClass cl) of
- Nothing -> False
- Just xs -> naughty_trace cl xs
-
- bad_id id
- = case (maybePurelyLocalType (getIdUniType id)) of
- Nothing -> False
- Just xs -> naughty_trace id xs
-
- bad_tc tc
- = case (maybePurelyLocalTyCon tc) of
- Nothing -> False
- Just xs -> if exported_abs then False else naughty_trace tc xs
- where
- exported_abs = case (getExportFlag tc) of { ExportAbs -> True; _ -> False }
-
- naughty_trace x things
- = pprTrace "Can't export -- `"
- (ppBesides [ppr PprForUser x, ppStr "' mentions purely local things: ",
- ppInterleave pp'SP things])
- True