2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[MkIface]{Print an interface for a module}
7 #include "HsVersions.h"
22 IMPORT_1_3(IO(Handle,hPutStr,openFile,hClose,IOMode(..)))
24 import Bag ( bagToList )
25 import Class ( GenClass(..){-instance NamedThing-}, GenClassOp(..) )
26 import CmdLineOpts ( opt_ProduceHi )
27 import FieldLabel ( FieldLabel{-instance NamedThing-} )
28 import FiniteMap ( emptyFM, addToFM, lookupFM, fmToList, eltsFM, FiniteMap )
30 import Id ( idType, dataConRawArgTys, dataConFieldLabels, isDataCon,
31 dataConStrictMarks, StrictnessMark(..),
32 GenId{-instance NamedThing/Outputable-}
34 import Maybes ( maybeToBool )
35 import Name ( origName, nameOf, moduleOf,
36 exportFlagOn, nameExportFlag, ExportFlag(..),
37 isLexSym, isLexCon, isLocallyDefined, isWiredInName,
38 RdrName(..){-instance Outputable-},
39 OrigName(..){-instance Ord-},
40 Name{-instance NamedThing-}
42 import ParseUtils ( UsagesMap(..), VersionsMap(..) )
43 import PprEnv -- not sure how much...
44 import PprStyle ( PprStyle(..) )
45 import PprType -- most of it (??)
46 --import PrelMods ( modulesWithBuiltins )
47 import PrelInfo ( builtinValNamesMap, builtinTcNamesMap )
48 import Pretty ( prettyToUn )
49 import Unpretty -- ditto
50 import RnHsSyn ( isRnConstr, SYN_IE(RenamedHsModule), RnName(..) )
51 import RnUtils ( SYN_IE(RnEnv), pprRnEnv{-ToDo:rm-} )
52 import TcModule ( SYN_IE(TcIfaceInfo) )
53 import TcInstUtil ( InstInfo(..) )
54 import TyCon ( TyCon(..){-instance NamedThing-}, NewOrData(..) )
55 import Type ( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy )
56 import Util ( sortLt, removeDups, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}, pprTrace{-ToDo:rm-} )
58 uppSemid x = uppBeside (prettyToUn (ppr PprInterface x)) uppSemi -- micro util
59 ppr_ty ty = prettyToUn (pprType PprInterface ty)
60 ppr_tyvar tv = prettyToUn (ppr PprInterface tv)
62 = case (origName "ppr_name" n) of { OrigName m s ->
63 uppBesides [uppPStr m, uppChar '.', uppPStr s] }
66 We have a function @startIface@ to open the output file and put
67 (something like) ``interface Foo'' in it. It gives back a handle
68 for subsequent additions to the interface file.
70 We then have one-function-per-block-of-interface-stuff, e.g.,
71 @ifaceExportList@ produces the @__exports__@ section; it appends
72 to the handle provided by @startIface@.
76 -> IO (Maybe Handle) -- Nothing <=> don't do an interface
77 endIface :: Maybe Handle -> IO ()
88 -> (Name -> ExportFlag, ([(Name,ExportFlag)], [(Name,ExportFlag)]))
99 ifaceDecls :: Maybe Handle
100 -> TcIfaceInfo -- info produced by typechecker, for interfaces
104 -> TcIfaceInfo -- as above
109 ifacePragmas = panic "ifacePragmas" -- stub
114 = case opt_ProduceHi of
115 Nothing -> return Nothing -- not producing any .hi file
117 openFile fn WriteMode >>= \ if_hdl ->
118 hPutStr if_hdl ("interface "++ _UNPK_ mod) >>
121 endIface Nothing = return ()
122 endIface (Just if_hdl) = hPutStr if_hdl "\n" >> hClose if_hdl
126 ifaceUsages Nothing{-no iface handle-} _ = return ()
128 ifaceUsages (Just if_hdl) usages
132 = hPutStr if_hdl "\n__usages__\n" >>
133 hPutStr if_hdl (uppShow 0 (uppAboves (map upp_uses usages_list)))
135 usages_list = fmToList usages -- NO: filter has_no_builtins (...)
137 -- has_no_builtins (m, _)
138 -- = m `notElem` modulesWithBuiltins
139 -- -- Don't *have* to do this; save gratuitous spillage in
140 -- -- every interface. Could be flag-controlled...
142 upp_uses (m, (mv, versions))
143 = uppBesides [uppPStr m, uppSP, uppInt mv, uppPStr SLIT(" :: "),
144 upp_versions (fmToList versions), uppSemi]
147 = uppIntersperse uppSP [ uppCat [uppPStr n, uppInt v] | (n,v) <- nvs ]
151 ifaceVersions Nothing{-no iface handle-} _ = return ()
153 ifaceVersions (Just if_hdl) version_info
157 = hPutStr if_hdl "\n__versions__\n" >>
158 hPutStr if_hdl (uppShow 0 (upp_versions version_list))
159 -- NB: when compiling Prelude.hs, this will spew out
160 -- stuff for [], (), (,), etc. [i.e., builtins], which
161 -- we'd rather it didn't. The version-mangling in
162 -- the driver will ignore them.
164 version_list = fmToList version_info
167 = uppAboves [ uppPStr n | (n,v) <- nvs ]
171 ifaceInstanceModules Nothing{-no iface handle-} _ = return ()
172 ifaceInstanceModules (Just _) [] = return ()
174 ifaceInstanceModules (Just if_hdl) imods
175 = hPutStr if_hdl "\n__instance_modules__\n" >>
176 hPutStr if_hdl (uppShow 0 (uppCat (map uppPStr imods)))
179 Export list: grab the Names of things that are marked Exported, sort
180 (so the interface file doesn't ``wobble'' from one compilation to the
181 next...), and print. We work from the renamer's final ``RnEnv'',
182 which has all the names we might possibly be interested in.
183 (Note that the ``module X'' export items can cause a lot of grief.)
185 ifaceExportList Nothing{-no iface handle-} _ _ = return ()
187 ifaceExportList (Just if_hdl)
188 (export_fn, (dotdot_vals, dotdot_tcs))
189 rn_env@((qual, unqual, tc_qual, tc_unqual), _)
191 name_flag_pairs :: FiniteMap OrigName ExportFlag
193 = foldr (from_wired True{-val-ish-})
194 (foldr (from_wired False{-tycon-ish-})
195 (foldr (from_dotdot True{-val-ish-})
196 (foldr (from_dotdot False{-tycon-ish-})
200 (foldr from_tc emptyFM{-init accum-}
207 (eltsFM builtinTcNamesMap))
208 (eltsFM builtinValNamesMap)
210 sorted_pairs = sortLt lexical_lt (fmToList name_flag_pairs)
213 --pprTrace "Exporting:" (pprRnEnv PprDebug rn_env) $
214 hPutStr if_hdl "\n__exports__\n" >>
215 hPutStr if_hdl (uppShow 0 (uppAboves (map upp_pair sorted_pairs)))
218 | fun_looking rn && exportFlagOn ef = addToFM acc on ef
221 ef = export_fn n -- NB: using the export fn!
223 on = origName "from_val" n
225 -- fun_looking: must avoid class ops and data constructors
226 -- and record fieldnames
227 fun_looking (RnName _) = True
228 fun_looking (WiredInId i) = not (isDataCon i)
229 fun_looking _ = False
232 | exportFlagOn ef = addToFM acc on ef
235 ef = export_fn n -- NB: using the export fn!
237 on = origName "from_tc" n
239 from_dotdot is_valish (n,ef) acc
240 | is_valish && isLexCon str = acc
241 | exportFlagOn ef = addToFM acc on ef
244 on = origName "from_dotdot" n
245 (OrigName _ str) = on
247 from_wired is_val_ish rn acc
248 | is_val_ish && not (fun_looking rn)
249 = acc -- these things don't cause export-ery
250 | exportFlagOn ef = addToFM acc on ef
255 on = origName "from_wired" n
258 lexical_lt (n1,_) (n2,_) = n1 < n2
261 upp_pair (OrigName m n, ef)
262 = uppBesides [uppPStr m, uppSP, uppPStr n, uppSP, upp_export ef]
264 upp_export ExportAll = uppPStr SLIT("(..)")
265 upp_export ExportAbs = uppNil
269 ifaceFixities Nothing{-no iface handle-} _ = return ()
271 ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _)
273 pp_fixities = foldr go [] fixities
275 if null pp_fixities then
278 hPutStr if_hdl "\n__fixities__\n" >>
279 hPutStr if_hdl (uppShow 0 (uppAboves pp_fixities))
281 go (InfixL v i) acc = (if isLocallyDefined v then (:) (print_fix "l" i v) else id) acc
282 go (InfixR v i) acc = (if isLocallyDefined v then (:) (print_fix "r" i v) else id) acc
283 go (InfixN v i) acc = (if isLocallyDefined v then (:) (print_fix "" i v) else id) acc
285 print_fix suff prec var
286 = uppBesides [uppPStr SLIT("infix"), uppStr suff, uppSP, uppInt prec, uppSP, ppr_name var, uppSemi]
290 non_wired x = not (isWiredInName (getName x)) --ToDo:move?
292 ifaceDecls Nothing{-no iface handle-} _ = return ()
294 ifaceDecls (Just if_hdl) (vals, tycons, classes, _)
295 = ASSERT(all isLocallyDefined vals)
296 ASSERT(all isLocallyDefined tycons)
297 ASSERT(all isLocallyDefined classes)
299 nonwired_classes = filter non_wired classes
300 nonwired_tycons = filter non_wired tycons
301 nonwired_vals = filter non_wired vals
303 lt_lexical a b = origName "lt_lexical" a < origName "lt_lexical" b
305 sorted_classes = sortLt lt_lexical nonwired_classes
306 sorted_tycons = sortLt lt_lexical nonwired_tycons
307 sorted_vals = sortLt lt_lexical nonwired_vals
309 if (null sorted_classes && null sorted_tycons && null sorted_vals) then
310 -- You could have a module with just (re-)exports/instances in it
313 hPutStr if_hdl "\n__declarations__\n" >>
314 hPutStr if_hdl (uppShow 0 (uppAboves [
315 uppAboves (map ppr_class sorted_classes),
316 uppAboves (map ppr_tycon sorted_tycons),
317 uppAboves [ppr_val v (idType v) | v <- sorted_vals]]))
321 ifaceInstances Nothing{-no iface handle-} _ = return ()
323 ifaceInstances (Just if_hdl) (_, _, _, insts)
325 togo_insts = filter is_togo_inst (bagToList insts)
327 sorted_insts = sortLt lt_inst togo_insts
329 if null togo_insts then
332 hPutStr if_hdl "\n__instances__\n" >>
333 hPutStr if_hdl (uppShow 0 (uppAboves (map pp_inst sorted_insts)))
335 is_togo_inst (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
336 = from_here -- && ...
339 lt_inst (InstInfo clas1 _ ty1 _ _ _ _ _ _ _ _ _)
340 (InstInfo clas2 _ ty2 _ _ _ _ _ _ _ _ _)
342 tycon1 = fst (getAppTyCon ty1)
343 tycon2 = fst (getAppTyCon ty2)
345 case (origName "lt_inst" clas1 `cmp` origName "lt_inst" clas2) of
348 EQ_ -> origName "lt_inst2" tycon1 < origName "lt_inst2" tycon2
351 pp_inst (InstInfo clas tvs ty theta _ _ _ _ _ _ _ _)
353 forall_ty = mkSigmaTy tvs theta (mkDictTy clas ty)
354 renumbered_ty = initNmbr (nmbrType forall_ty)
356 case (splitForAllTy renumbered_ty) of { (rtvs, rrho_ty) ->
357 uppBesides [uppPStr SLIT("instance "), ppr_forall rtvs, ppr_ty rrho_ty, uppSemi] }
360 %************************************************************************
362 \subsection{Printing tycons, classes, ...}
364 %************************************************************************
367 ppr_class :: Class -> Unpretty
370 = --pprTrace "ppr_class:" (ppr PprDebug c) $
371 case (initNmbr (nmbrClass c)) of { -- renumber it!
372 Class _ n tyvar super_classes sdsels ops sels defms insts links ->
374 uppCat [uppPStr SLIT("class"), ppr_context tyvar super_classes,
375 ppr_name n, ppr_tyvar tyvar,
378 else uppCat [uppStr "where {", uppCat (map ppr_op ops), uppStr "};"]]
381 ppr_context :: TyVar -> [Class] -> Unpretty
383 ppr_context tv [] = uppNil
384 -- ppr_context tv [sc] = uppBeside (ppr_assert tv sc) (uppPStr SLIT(" =>"))
385 ppr_context tv super_classes
386 = uppBesides [uppStr "{{",
387 uppIntersperse upp'SP{-'-} (map (ppr_assert tv) super_classes),
390 ppr_assert tv (Class _ n _ _ _ _ _ _ _ _) = uppCat [ppr_name n, ppr_tyvar tv]
392 clas_mod = moduleOf (origName "ppr_class" c)
394 ppr_op (ClassOp o _ ty) = pp_sig (Qual clas_mod o) ty
398 ppr_val v ty -- renumber the type first!
399 = --pprTrace "ppr_val:" (ppr PprDebug v) $
400 pp_sig v (initNmbr (nmbrType ty))
403 = case (splitForAllTy ty) of { (tvs, rho_ty) ->
404 uppBesides [ppr_name op, uppPStr SLIT(" :: "), ppr_forall tvs, ppr_ty rho_ty, uppSemi] }
406 ppr_forall [] = uppNil
407 ppr_forall tvs = uppBesides [ uppStr "__forall__ [", uppInterleave uppComma (map ppr_tyvar tvs), uppStr "] " ]
412 = --pprTrace "ppr_tycon:" (ppr PprDebug tycon) $
413 ppr_tc (initNmbr (nmbrTyCon tycon))
415 ------------------------
416 ppr_tc (PrimTyCon _ n _ _)
417 = uppCat [ uppStr "{- data", ppr_name n, uppStr " *built-in* -}" ]
420 = uppCat [ uppStr "{- data", ppr_name FunTyCon, uppStr " *built-in* -}" ]
422 ppr_tc (TupleTyCon _ n _)
423 = uppCat [ uppStr "{- ", ppr_name n, uppStr "-}" ]
425 ppr_tc (SynTyCon _ n _ _ tvs expand)
427 pp_tyvars = map ppr_tyvar tvs
429 uppBesides [uppPStr SLIT("type "), ppr_name n, uppSP, uppIntersperse uppSP pp_tyvars,
430 uppPStr SLIT(" = "), ppr_ty expand, uppSemi]
432 ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new)
433 = uppCat [pp_data_or_new,
436 uppIntersperse uppSP (map ppr_tyvar tvs),
437 uppEquals, pp_condecls,
439 -- NB: we do not print deriving info in interfaces
441 pp_data_or_new = case data_or_new of
442 DataType -> uppPStr SLIT("data")
443 NewType -> uppPStr SLIT("newtype")
445 ppr_context [] = uppNil
446 -- ppr_context [(c,t)] = uppCat [ppr_name c, ppr_ty t, uppPStr SLIT("=>")]
448 = uppBesides[uppStr "{{",
449 uppInterleave uppComma [uppCat [ppr_name c, ppr_ty t] | (c,t) <- cs],
450 uppStr "}}", uppPStr SLIT(" =>")]
456 uppCat ((ppr_con c) : (map ppr_next_con cs))
458 ppr_next_con con = uppCat [uppChar '|', ppr_con con]
462 con_arg_tys = dataConRawArgTys con
463 labels = dataConFieldLabels con -- none if not a record
464 strict_marks = dataConStrictMarks con
466 uppCat [ppr_name con, ppr_fields labels strict_marks con_arg_tys]
468 ppr_fields labels strict_marks con_arg_tys
469 = if null labels then -- not a record thingy
470 uppIntersperse uppSP (zipWithEqual "ppr_fields" ppr_bang_ty strict_marks con_arg_tys)
472 uppCat [ uppChar '{',
473 uppInterleave uppComma (zipWith3Equal "ppr_field" ppr_field labels strict_marks con_arg_tys),
477 = uppBeside (case b of { MarkedStrict -> uppChar '!'; _ -> uppNil })
478 (prettyToUn (pprParendType PprInterface t))
481 = uppBesides [ppr_name l, uppPStr SLIT(" :: "),
482 case b of { MarkedStrict -> uppChar '!'; _ -> uppNil },