2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
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 ( prettyToUn )
45 import Unpretty -- ditto
46 import RnHsSyn ( RenamedHsModule(..), RnName{-instance NamedThing-} )
47 import TcModule ( TcIfaceInfo(..) )
48 import TcInstUtil ( InstInfo(..) )
49 import TyCon ( TyCon(..){-instance NamedThing-}, NewOrData(..) )
50 import Type ( mkSigmaTy, mkDictTy, getAppTyCon )
51 import Util ( sortLt, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}, pprTrace{-ToDo:rm-} )
53 uppSemid x = uppBeside (prettyToUn (ppr PprInterface x)) uppSemi -- micro util
54 ppr_ty ty = prettyToUn (pprType PprInterface ty)
55 ppr_tyvar tv = prettyToUn (ppr PprInterface tv)
60 pp = prettyToUn (ppr PprInterface on)
62 (if isLexSym s then uppParens else id) pp
69 (if isLexSym s then uppParens else id) pp
72 We have a function @startIface@ to open the output file and put
73 (something like) ``interface Foo'' in it. It gives back a handle
74 for subsequent additions to the interface file.
76 We then have one-function-per-block-of-interface-stuff, e.g.,
77 @ifaceExportList@ produces the @__exports__@ section; it appends
78 to the handle provided by @startIface@.
82 -> IO (Maybe Handle) -- Nothing <=> don't do an interface
83 endIface :: Maybe Handle -> IO ()
104 ifaceDecls :: Maybe Handle
105 -> TcIfaceInfo -- info produced by typechecker, for interfaces
109 -> TcIfaceInfo -- as above
114 ifacePragmas = panic "ifacePragmas" -- stub
119 = case opt_ProduceHi of
120 Nothing -> return Nothing -- not producing any .hi file
122 openFile fn WriteMode >>= \ if_hdl ->
123 hPutStr if_hdl ("interface "++ _UNPK_ mod) >>
126 endIface Nothing = return ()
127 endIface (Just if_hdl) = hPutStr if_hdl "\n" >> hClose if_hdl
131 ifaceUsages Nothing{-no iface handle-} _ = return ()
133 ifaceUsages (Just if_hdl) usages
137 = hPutStr if_hdl "\n__usages__\n" >>
138 hPutStr if_hdl (uppShow 0 (uppAboves (map upp_uses usages_list)))
140 usages_list = fmToList usages
142 upp_uses (m, (mv, versions))
143 = uppBesides [uppPStr m, uppSP, uppInt mv, uppPStr SLIT(" :: "),
144 upp_versions (fmToList versions), uppSemi]
147 = uppIntersperse upp'SP{-'-} [ uppCat [(if isLexSym n then uppParens else id) (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))
160 version_list = fmToList version_info
163 = uppAboves [ (if isLexSym n then uppParens else id) (uppPStr n) | (n,v) <- nvs ]
167 ifaceInstanceModules Nothing{-no iface handle-} _ = return ()
168 ifaceInstanceModules (Just _) [] = return ()
170 ifaceInstanceModules (Just if_hdl) imods
171 = hPutStr if_hdl "\n__instance_modules__\n" >>
172 hPutStr if_hdl (uppShow 0 (uppCat (map uppPStr imods)))
175 Export list: grab the Names of things that are marked Exported, sort
176 (so the interface file doesn't ``wobble'' from one compilation to the
177 next...), and print. Note that the ``module'' now contains all the
178 imported things that we are dealing with, thus including any entities
179 that we are re-exporting from somewhere else.
181 ifaceExportList Nothing{-no iface handle-} _ = return ()
183 ifaceExportList (Just if_hdl)
184 (HsModule _ _ _ _ _ typedecls _ classdecls _ _ _ binds sigs _)
186 name_flag_pairs :: Bag (Name, ExportFlag)
191 (from_binds binds emptyBag{-init accum-})
196 sorted_pairs = sortLt lexical_lt (bagToList name_flag_pairs)
199 hPutStr if_hdl "\n__exports__\n" >>
200 hPutStr if_hdl (uppShow 0 (uppAboves (map upp_pair sorted_pairs)))
202 from_ty (TyData _ n _ _ _ _ _) acc = maybe_add acc n
203 from_ty (TyNew _ n _ _ _ _ _) acc = maybe_add acc n
204 from_ty (TySynonym n _ _ _) acc = maybe_add acc n
206 from_cls (ClassDecl _ n _ _ _ _ _) acc = maybe_add acc n
208 from_sig (Sig n _ _ _) acc = maybe_add acc n
210 from_binds bs acc = maybe_add_list acc (collectTopLevelBinders bs)
213 maybe_add :: Bag (Name, ExportFlag) -> RnName -> Bag (Name, ExportFlag)
216 | exportFlagOn ef = acc `snocBag` (n, ef)
220 ef = nameExportFlag n
223 maybe_add_list acc [] = acc
224 maybe_add_list acc (n:ns) = maybe_add (maybe_add_list acc ns) n
227 lexical_lt (n1,_) (n2,_) = nameOrigName n1 < nameOrigName n2
231 = uppBeside (ppr_name n) (upp_export ef)
233 upp_export ExportAll = uppPStr SLIT("(..)")
234 upp_export ExportAbs = uppNil
238 ifaceFixities Nothing{-no iface handle-} _ = return ()
240 ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _)
242 local_fixities = filter from_here fixities
244 if null local_fixities then
247 hPutStr if_hdl "\n__fixities__\n" >>
248 hPutStr if_hdl (uppShow 0 (uppAboves (map uppSemid local_fixities)))
250 from_here (InfixL v _) = isLocallyDefined v
251 from_here (InfixR v _) = isLocallyDefined v
252 from_here (InfixN v _) = isLocallyDefined v
256 ifaceDecls Nothing{-no iface handle-} _ = return ()
258 ifaceDecls (Just if_hdl) (vals, tycons, classes, _)
260 togo_classes = [ c | c <- classes, isLocallyDefined c ]
261 togo_tycons = [ t | t <- tycons, isLocallyDefined t ]
262 togo_vals = [ v | v <- vals, isLocallyDefined v ]
264 sorted_classes = sortLt ltLexical togo_classes
265 sorted_tycons = sortLt ltLexical togo_tycons
266 sorted_vals = sortLt ltLexical togo_vals
268 if (null sorted_classes && null sorted_tycons && null sorted_vals) then
269 -- You could have a module with just instances in it
272 hPutStr if_hdl "\n__declarations__\n" >>
273 hPutStr if_hdl (uppShow 0 (uppAboves [
274 uppAboves (map ppr_class sorted_classes),
275 uppAboves (map ppr_tycon sorted_tycons),
276 uppAboves [ppr_val v (idType v) | v <- sorted_vals]]))
280 ifaceInstances Nothing{-no iface handle-} _ = return ()
282 ifaceInstances (Just if_hdl) (_, _, _, insts)
284 togo_insts = filter is_togo_inst (bagToList insts)
286 sorted_insts = sortLt lt_inst togo_insts
288 if null togo_insts then
291 hPutStr if_hdl "\n__instances__\n" >>
292 hPutStr if_hdl (uppShow 0 (uppAboves (map pp_inst sorted_insts)))
294 is_togo_inst (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
295 = from_here -- && ...
298 lt_inst (InstInfo clas1 _ ty1 _ _ _ _ _ _ _ _ _)
299 (InstInfo clas2 _ ty2 _ _ _ _ _ _ _ _ _)
301 tycon1 = fst (getAppTyCon ty1)
302 tycon2 = fst (getAppTyCon ty2)
304 case (origName clas1 `cmp` origName clas2) of
307 EQ_ -> origName tycon1 < origName tycon2
310 pp_inst (InstInfo clas tvs ty theta _ _ _ _ _ _ _ _)
312 forall_ty = mkSigmaTy tvs theta (mkDictTy clas ty)
313 renumbered_ty = initNmbr (nmbrType forall_ty)
315 uppBesides [uppPStr SLIT("instance "), ppr_ty renumbered_ty, uppSemi]
318 %************************************************************************
320 \subsection{Printing tycons, classes, ...}
322 %************************************************************************
325 ppr_class :: Class -> Unpretty
328 = --pprTrace "ppr_class:" (ppr PprDebug c) $
329 case (initNmbr (nmbrClass c)) of { -- renumber it!
330 Class _ n tyvar super_classes sdsels ops sels defms insts links ->
332 uppCat [uppPStr SLIT("class"), ppr_theta tyvar super_classes,
333 ppr_name n, ppr_tyvar tyvar,
336 else uppCat [uppStr "where {", uppCat (map ppr_op ops), uppStr "};"]]
339 ppr_theta :: TyVar -> [Class] -> Unpretty
341 ppr_theta tv [] = uppNil
342 ppr_theta tv [sc] = uppBeside (ppr_assert tv sc) (uppPStr SLIT(" =>"))
343 ppr_theta tv super_classes
344 = uppBesides [uppLparen,
345 uppIntersperse upp'SP{-'-} (map (ppr_assert tv) super_classes),
348 ppr_assert tv (Class _ n _ _ _ _ _ _ _ _) = uppCat [ppr_name n, ppr_tyvar tv]
350 ppr_op (ClassOp o _ ty) = pp_sig (Unqual o) ty
354 ppr_val v ty -- renumber the type first!
355 = --pprTrace "ppr_val:" (ppr PprDebug v) $
356 pp_sig v (initNmbr (nmbrType ty))
359 = uppBesides [ppr_name op, uppPStr SLIT(" :: "), ppr_ty ty, uppSemi]
364 = --pprTrace "ppr_tycon:" (ppr PprDebug tycon) $
365 ppr_tc (initNmbr (nmbrTyCon tycon))
367 ------------------------
368 ppr_tc (PrimTyCon _ n _)
369 = uppCat [ uppStr "{- data", ppr_name n, uppStr " *built-in* -}" ]
372 = uppCat [ uppStr "{- data", ppr_name FunTyCon, uppStr " *built-in* -}" ]
374 ppr_tc (TupleTyCon _ n _)
375 = uppCat [ uppStr "{- ", ppr_name n, uppStr "-}" ]
377 ppr_tc (SynTyCon _ n _ _ tvs expand)
379 pp_tyvars = map ppr_tyvar tvs
381 uppBesides [uppPStr SLIT("type "), ppr_name n, uppSP, uppIntersperse uppSP pp_tyvars,
382 uppPStr SLIT(" = "), ppr_ty expand, uppSemi]
384 ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new)
385 = uppCat [pp_data_or_new,
388 uppIntersperse uppSP (map ppr_tyvar tvs),
389 pp_unabstract_condecls,
391 -- NB: we do not print deriving info in interfaces
393 pp_data_or_new = case data_or_new of
394 DataType -> uppPStr SLIT("data")
395 NewType -> uppPStr SLIT("newtype")
397 ppr_context [] = uppNil
398 ppr_context [(c,t)] = uppCat [ppr_name c, ppr_ty t, uppPStr SLIT("=>")]
400 = uppBesides[uppLparen,
401 uppInterleave uppComma [uppCat [ppr_name c, ppr_ty t] | (c,t) <- cs],
402 uppRparen, uppPStr SLIT(" =>")]
404 yes_we_print_condecls
405 = case (getExportFlag n) of
409 pp_unabstract_condecls
410 = if yes_we_print_condecls
411 then uppCat [uppEquals, pp_condecls]
418 uppCat ((ppr_con c) : (map ppr_next_con cs))
420 ppr_next_con con = uppCat [uppChar '|', ppr_con con]
424 (_, _, con_arg_tys, _) = dataConSig con
425 labels = dataConFieldLabels con -- none if not a record
426 strict_marks = dataConStrictMarks con
428 uppCat [ppr_unq_name con, ppr_fields labels strict_marks con_arg_tys]
430 ppr_fields labels strict_marks con_arg_tys
431 = if null labels then -- not a record thingy
432 uppIntersperse uppSP (zipWithEqual "ppr_fields" ppr_bang_ty strict_marks con_arg_tys)
434 uppCat [ uppChar '{',
435 uppInterleave uppComma (zipWith3Equal "ppr_field" ppr_field labels strict_marks con_arg_tys),
439 = uppBeside (case b of { MarkedStrict -> uppChar '!'; _ -> uppNil })
440 (prettyToUn (pprParendType PprInterface t))
443 = uppBesides [ppr_unq_name l, uppPStr SLIT(" :: "),
444 case b of { MarkedStrict -> uppChar '!'; _ -> uppNil },