2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
4 \section[MkIface]{Print an interface for a module}
7 #include "HsVersions.h"
23 import Bag ( emptyBag, snocBag, bagToList )
24 import Class ( GenClass(..){-instance NamedThing-}, GenClassOp(..) )
25 import CmdLineOpts ( opt_ProduceHi )
26 import FieldLabel ( FieldLabel{-instance NamedThing-} )
27 import FiniteMap ( fmToList )
29 import Id ( idType, dataConSig, dataConFieldLabels,
30 dataConStrictMarks, StrictnessMark(..),
31 GenId{-instance NamedThing/Outputable-}
33 import Name ( nameOrigName, origName, nameOf,
34 exportFlagOn, nameExportFlag, ExportFlag(..),
35 ltLexical, isExported, getExportFlag,
36 isLexSym, isLocallyDefined,
37 RdrName(..){-instance Outputable-},
38 Name{-instance NamedThing-}
40 import ParseUtils ( UsagesMap(..), VersionsMap(..) )
41 import PprEnv -- not sure how much...
42 import PprStyle ( PprStyle(..) )
43 import PprType -- most of it (??)
44 import Pretty -- quite a bit
45 import RnHsSyn ( RenamedHsModule(..), RnName{-instance NamedThing-} )
46 import TcModule ( TcIfaceInfo(..) )
47 import TcInstUtil ( InstInfo(..) )
48 import TyCon ( TyCon(..){-instance NamedThing-}, NewOrData(..) )
49 import Type ( mkSigmaTy, mkDictTy, getAppTyCon )
50 import Util ( sortLt, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}, pprTrace{-ToDo:rm-} )
52 ppSemid x = ppBeside (ppr PprInterface x) ppSemi -- micro util
53 ppr_ty ty = pprType PprInterface ty
54 ppr_tyvar tv = ppr PprInterface tv
59 pp = ppr PprInterface on
61 (if isLexSym s then ppParens else id) pp
68 (if isLexSym s then ppParens else id) pp
71 We have a function @startIface@ to open the output file and put
72 (something like) ``interface Foo N'' in it. It gives back a handle
73 for subsequent additions to the interface file.
75 We then have one-function-per-block-of-interface-stuff, e.g.,
76 @ifaceExportList@ produces the @__exports__@ section; it appends
77 to the handle provided by @startIface@.
81 -> IO (Maybe Handle) -- Nothing <=> don't do an interface
82 endIface :: Maybe Handle -> IO ()
103 ifaceDecls :: Maybe Handle
104 -> TcIfaceInfo -- info produced by typechecker, for interfaces
108 -> TcIfaceInfo -- as above
113 ifacePragmas = panic "ifacePragmas" -- stub
118 = case opt_ProduceHi of
119 Nothing -> return Nothing -- not producing any .hi file
121 openFile fn WriteMode >>= \ if_hdl ->
122 hPutStr if_hdl ("interface "++ _UNPK_ mod ++" 1\n") >>
125 endIface Nothing = return ()
126 endIface (Just if_hdl) = hPutStr if_hdl "\n" >> hClose if_hdl
130 ifaceUsages Nothing{-no iface handle-} _ = return ()
132 ifaceUsages (Just if_hdl) usages
136 = hPutStr if_hdl "__usages__\n" >>
137 hPutStr if_hdl (ppShow 10000 (ppAboves (map pp_uses usages_list)))
139 usages_list = fmToList usages
141 pp_uses (m, (mv, versions))
142 = ppBesides [ppPStr m, ppSP, ppInt mv, ppPStr SLIT(" :: "),
143 pp_versions (fmToList versions), ppSemi]
147 ifaceVersions Nothing{-no iface handle-} _ = return ()
149 ifaceVersions (Just if_hdl) version_info
153 = hPutStr if_hdl "\n__versions__\n" >>
154 hPutStr if_hdl (ppShow 10000 (pp_versions version_list))
156 version_list = fmToList version_info
159 = ppInterleave ppComma [ ppCat [ppPStr n, ppInt v] | (n,v) <- nvs ]
163 ifaceInstanceModules Nothing{-no iface handle-} _ = return ()
164 ifaceInstanceModules (Just _) [] = return ()
166 ifaceInstanceModules (Just if_hdl) imods
167 = hPutStr if_hdl "\n__instance_modules__\n" >>
168 hPutStr if_hdl (ppShow 100 (ppCat (map ppPStr imods)))
171 Export list: grab the Names of things that are marked Exported, sort
172 (so the interface file doesn't ``wobble'' from one compilation to the
173 next...), and print. Note that the ``module'' now contains all the
174 imported things that we are dealing with, thus including any entities
175 that we are re-exporting from somewhere else.
177 ifaceExportList Nothing{-no iface handle-} _ = return ()
179 ifaceExportList (Just if_hdl)
180 (HsModule _ _ _ _ _ typedecls _ classdecls _ _ _ binds sigs _)
182 name_flag_pairs :: Bag (Name, ExportFlag)
187 (from_binds binds emptyBag{-init accum-})
192 sorted_pairs = sortLt lexical_lt (bagToList name_flag_pairs)
195 hPutStr if_hdl "\n__exports__\n" >>
196 hPutStr if_hdl (ppShow 100 (ppAboves (map pp_pair sorted_pairs)))
198 from_ty (TyData _ n _ _ _ _ _) acc = maybe_add acc n
199 from_ty (TyNew _ n _ _ _ _ _) acc = maybe_add acc n
200 from_ty (TySynonym n _ _ _) acc = maybe_add acc n
202 from_cls (ClassDecl _ n _ _ _ _ _) acc = maybe_add acc n
204 from_sig (Sig n _ _ _) acc = maybe_add acc n
206 from_binds bs acc = maybe_add_list acc (collectTopLevelBinders bs)
209 maybe_add :: Bag (Name, ExportFlag) -> RnName -> Bag (Name, ExportFlag)
212 | exportFlagOn ef = acc `snocBag` (n, ef)
216 ef = nameExportFlag n
219 maybe_add_list acc [] = acc
220 maybe_add_list acc (n:ns) = maybe_add (maybe_add_list acc ns) n
223 lexical_lt (n1,_) (n2,_) = nameOrigName n1 < nameOrigName n2
227 = ppBeside (ppr_name n) (pp_export ef)
229 pp_export ExportAll = ppPStr SLIT("(..)")
230 pp_export ExportAbs = ppNil
234 ifaceFixities Nothing{-no iface handle-} _ = return ()
236 ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _)
238 local_fixities = filter from_here fixities
240 if null local_fixities then
243 hPutStr if_hdl "\n__fixities__\n" >>
244 hPutStr if_hdl (ppShow 100 (ppAboves (map ppSemid local_fixities)))
246 from_here (InfixL v _) = isLocallyDefined v
247 from_here (InfixR v _) = isLocallyDefined v
248 from_here (InfixN v _) = isLocallyDefined v
252 ifaceDecls Nothing{-no iface handle-} _ = return ()
254 ifaceDecls (Just if_hdl) (vals, tycons, classes, _)
256 exported_classes = filter isExported classes
257 exported_tycons = filter isExported tycons
258 exported_vals = filter isExported vals
260 sorted_classes = sortLt ltLexical exported_classes
261 sorted_tycons = sortLt ltLexical exported_tycons
262 sorted_vals = sortLt ltLexical exported_vals
264 ASSERT(not (null exported_classes && null exported_tycons && null exported_vals))
266 hPutStr if_hdl "\n__declarations__\n" >>
267 hPutStr if_hdl (ppShow 100 (ppAboves [
268 ppAboves (map ppr_class sorted_classes),
269 ppAboves (map ppr_tycon sorted_tycons),
270 ppAboves [ppr_val v (idType v) | v <- sorted_vals]]))
274 ifaceInstances Nothing{-no iface handle-} _ = return ()
276 ifaceInstances (Just if_hdl) (_, _, _, insts)
278 exported_insts = filter is_exported_inst (bagToList insts)
280 sorted_insts = sortLt lt_inst exported_insts
282 if null exported_insts then
285 hPutStr if_hdl "\n__instances__\n" >>
286 hPutStr if_hdl (ppShow 100 (ppAboves (map pp_inst sorted_insts)))
288 is_exported_inst (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
289 = from_here -- && ...
292 lt_inst (InstInfo clas1 _ ty1 _ _ _ _ _ _ _ _ _)
293 (InstInfo clas2 _ ty2 _ _ _ _ _ _ _ _ _)
295 tycon1 = fst (getAppTyCon ty1)
296 tycon2 = fst (getAppTyCon ty2)
298 case (origName clas1 `cmp` origName clas2) of
301 EQ_ -> origName tycon1 < origName tycon2
304 pp_inst (InstInfo clas tvs ty theta _ _ _ _ _ _ _ _)
306 forall_ty = mkSigmaTy tvs theta (mkDictTy clas ty)
307 renumbered_ty = initNmbr (nmbrType forall_ty)
309 ppBesides [ppPStr SLIT("instance "), ppr_ty renumbered_ty, ppSemi]
312 %************************************************************************
314 \subsection{Printing tycons, classes, ...}
316 %************************************************************************
319 ppr_class :: Class -> Pretty
322 = --pprTrace "ppr_class:" (ppr PprDebug c) $
323 case (initNmbr (nmbrClass c)) of { -- renumber it!
324 Class _ n tyvar super_classes sdsels ops sels defms insts links ->
326 ppAbove (ppCat [ppPStr SLIT("class"), ppr_theta tyvar super_classes,
327 ppr_name n, ppr_tyvar tyvar,
328 if null ops then ppSemi else ppStr "where {"])
331 else ppAbove (ppNest 2 (ppAboves (map ppr_op ops)))
336 ppr_theta :: TyVar -> [Class] -> Pretty
338 ppr_theta tv [] = ppNil
339 ppr_theta tv [sc] = ppBeside (ppr_assert tv sc) (ppStr " =>")
340 ppr_theta tv super_classes
341 = ppBesides [ppLparen,
342 ppIntersperse pp'SP{-'-} (map (ppr_assert tv) super_classes),
345 ppr_assert tv (Class _ n _ _ _ _ _ _ _ _) = ppCat [ppr_name n, ppr_tyvar tv]
347 ppr_op (ClassOp o _ ty) = pp_sig (Unqual o) ty
351 ppr_val v ty -- renumber the type first!
352 = --pprTrace "ppr_val:" (ppr PprDebug v) $
353 pp_sig v (initNmbr (nmbrType ty))
356 = ppBesides [ppr_name op, ppPStr SLIT(" :: "), ppr_ty ty, ppSemi]
361 = --pprTrace "ppr_tycon:" (ppr PprDebug tycon) $
362 ppr_tc (initNmbr (nmbrTyCon tycon))
364 ------------------------
365 ppr_tc (PrimTyCon _ n _)
366 = ppCat [ ppStr "{- data", ppr_name n, ppStr " *built-in* -}" ]
369 = ppCat [ ppStr "{- data", ppr_name FunTyCon, ppStr " *built-in* -}" ]
371 ppr_tc (TupleTyCon _ n _)
372 = ppCat [ ppStr "{- ", ppr_name n, ppStr "-}" ]
374 ppr_tc (SynTyCon _ n _ _ tvs expand)
376 pp_tyvars = map ppr_tyvar tvs
378 ppBesides [ppPStr SLIT("type "), ppr_name n, ppSP, ppIntersperse ppSP pp_tyvars,
379 ppPStr SLIT(" = "), ppr_ty expand, ppSemi]
381 ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new)
382 = ppHang (ppCat [pp_data_or_new,
385 ppIntersperse ppSP (map ppr_tyvar tvs)])
387 (ppBeside pp_unabstract_condecls ppSemi)
388 -- NB: we do not print deriving info in interfaces
390 pp_data_or_new = case data_or_new of
391 DataType -> ppPStr SLIT("data")
392 NewType -> ppPStr SLIT("newtype")
394 ppr_context [] = ppNil
395 ppr_context [(c,t)] = ppCat [ppr_name c, ppr_ty t, ppStr "=>"]
397 = ppBesides[ppLparen,
398 ppInterleave ppComma [ppCat [ppr_name c, ppr_ty t] | (c,t) <- cs],
399 ppRparen, ppStr " =>"]
401 yes_we_print_condecls
402 = case (getExportFlag n) of
406 pp_unabstract_condecls
407 = if yes_we_print_condecls
408 then ppCat [ppEquals, pp_condecls]
415 ppSep ((ppr_con c) : (map ppr_next_con cs))
417 ppr_next_con con = ppCat [ppChar '|', ppr_con con]
421 (_, _, con_arg_tys, _) = dataConSig con
422 labels = dataConFieldLabels con -- none if not a record
423 strict_marks = dataConStrictMarks con
425 ppCat [ppr_unq_name con, ppr_fields labels strict_marks con_arg_tys]
427 ppr_fields labels strict_marks con_arg_tys
428 = if null labels then -- not a record thingy
429 ppIntersperse ppSP (zipWithEqual ppr_bang_ty strict_marks con_arg_tys)
432 ppInterleave ppComma (zipWith3Equal ppr_field labels strict_marks con_arg_tys),
436 = ppBeside (case b of { MarkedStrict -> ppChar '!'; _ -> ppNil })
437 (pprParendType PprInterface t)
440 = ppBesides [ppr_unq_name l, ppPStr SLIT(" :: "),
441 case b of { MarkedStrict -> ppChar '!'; _ -> ppNil },