ghc/compiler/main/MkIface.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
   3 %
   4 \section[MkIface]{Print an interface for a module}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module MkIface (
  10         startIface, endIface,
  11         ifaceUsages,
  12         ifaceVersions,
  13         ifaceExportList,
  14         ifaceFixities,
  15         ifaceInstanceModules,
  16         ifaceDecls,
  17         ifaceInstances,
  18         ifacePragmas
  19     ) where
  20
  21 import Ubiq{-uitous-}
  22
  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 HsSyn
  28 import Id               ( idType, dataConSig, dataConFieldLabels,
  29                           dataConStrictMarks, StrictnessMark(..),
  30                           GenId{-instance NamedThing/Outputable-}
  31                         )
  32 import Name             ( nameOrigName, origName, nameOf,
  33                           exportFlagOn, nameExportFlag, ExportFlag(..),
  34                           ltLexical, isExported, getExportFlag,
  35                           isLexSym, isLocallyDefined,
  36                           RdrName(..){-instance Outputable-},
  37                           Name{-instance NamedThing-}
  38                         )
  39 import ParseUtils       ( UsagesMap(..), VersionsMap(..) )
  40 import PprEnv           -- not sure how much...
  41 import PprStyle         ( PprStyle(..) )
  42 import PprType          -- most of it (??)
  43 import Pretty           -- quite a bit
  44 import RnHsSyn          ( RenamedHsModule(..), RnName{-instance NamedThing-} )
  45 import TcModule         ( TcIfaceInfo(..) )
  46 import TcInstUtil       ( InstInfo(..) )
  47 import TyCon            ( TyCon(..){-instance NamedThing-}, NewOrData(..) )
  48 import Type             ( mkSigmaTy, mkDictTy, getAppTyCon )
  49 import Util             ( sortLt, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}, pprTrace{-ToDo:rm-} )
  50
  51 ppSemid    x = ppBeside (ppr PprInterface x) ppSemi -- micro util
  52 ppr_ty    ty = pprType PprInterface ty
  53 ppr_tyvar tv = ppr PprInterface tv
  54 ppr_name   n
  55   = let
  56         on = origName n
  57         s  = nameOf  on
  58         pp = ppr PprInterface on
  59     in
  60     (if isLexSym s then ppParens else id) pp
  61 ppr_unq_name n
  62   = let
  63         on = origName n
  64         s  = nameOf  on
  65         pp = ppPStr   s
  66     in
  67     (if isLexSym s then ppParens else id) pp
  68 \end{code}
  69
  70 We have a function @startIface@ to open the output file and put
  71 (something like) ``interface Foo N'' in it.  It gives back a handle
  72 for subsequent additions to the interface file.
  73
  74 We then have one-function-per-block-of-interface-stuff, e.g.,
  75 @ifaceExportList@ produces the @__exports__@ section; it appends
  76 to the handle provided by @startIface@.
  77
  78 \begin{code}
  79 startIface  :: Module
  80             -> IO (Maybe Handle) -- Nothing <=> don't do an interface
  81 endIface    :: Maybe Handle -> IO ()
  82 ifaceUsages
  83             :: Maybe Handle
  84             -> UsagesMap
  85             -> IO ()
  86 ifaceVersions
  87             :: Maybe Handle
  88             -> VersionsMap
  89             -> IO ()
  90 ifaceExportList
  91             :: Maybe Handle
  92             -> RenamedHsModule
  93             -> IO ()
  94 ifaceFixities
  95             :: Maybe Handle
  96             -> RenamedHsModule
  97             -> IO ()
  98 ifaceInstanceModules
  99             :: Maybe Handle
 100             -> [Module]
 101             -> IO ()
 102 ifaceDecls  :: Maybe Handle
 103             -> TcIfaceInfo  -- info produced by typechecker, for interfaces
 104             -> IO ()
 105 ifaceInstances
 106             :: Maybe Handle
 107             -> TcIfaceInfo  -- as above
 108             -> IO ()
 109 ifacePragmas
 110             :: Maybe Handle
 111             -> IO ()
 112 ifacePragmas = panic "ifacePragmas" -- stub
 113 \end{code}
 114
 115 \begin{code}
 116 startIface mod
 117   = case opt_ProduceHi of
 118       Nothing -> return Nothing -- not producing any .hi file
 119       Just fn ->
 120         openFile fn WriteMode   >>= \ if_hdl ->
 121         hPutStr if_hdl ("interface "++ _UNPK_ mod ++" 1\n") >>
 122         return (Just if_hdl)
 123
 124 endIface Nothing        = return ()
 125 endIface (Just if_hdl)  = hPutStr if_hdl "\n" >> hClose if_hdl
 126 \end{code}
 127
 128 \begin{code}
 129 ifaceUsages Nothing{-no iface handle-} _ = return ()
 130
 131 ifaceUsages (Just if_hdl) version_info
 132   = hPutStr if_hdl "__usages__\nFoo 1" -- a stub, obviously
 133 \end{code}
 134
 135 \begin{code}
 136 ifaceVersions Nothing{-no iface handle-} _ = return ()
 137
 138 ifaceVersions (Just if_hdl) version_info
 139   = hPutStr if_hdl "\n__versions__\nFoo 1" -- a stub, obviously
 140 \end{code}
 141
 142 \begin{code}
 143 ifaceInstanceModules Nothing{-no iface handle-} _ = return ()
 144 ifaceInstanceModules (Just _)                  [] = return ()
 145
 146 ifaceInstanceModules (Just if_hdl) imods
 147   = hPutStr if_hdl "\n__instance_modules__\n" >>
 148     hPutStr if_hdl (ppShow 100 (ppCat (map ppPStr imods)))
 149 \end{code}
 150
 151 Export list: grab the Names of things that are marked Exported, sort
 152 (so the interface file doesn't ``wobble'' from one compilation to the
 153 next...), and print.  Note that the ``module'' now contains all the
 154 imported things that we are dealing with, thus including any entities
 155 that we are re-exporting from somewhere else.
 156 \begin{code}
 157 ifaceExportList Nothing{-no iface handle-} _ = return ()
 158
 159 ifaceExportList (Just if_hdl)
 160                 (HsModule _ _ _ _ _ typedecls _ classdecls _ _ _ binds sigs _)
 161   = let
 162         name_flag_pairs :: Bag (Name, ExportFlag)
 163         name_flag_pairs
 164           = foldr from_ty
 165            (foldr from_cls
 166            (foldr from_sig
 167            (from_binds binds emptyBag{-init accum-})
 168              sigs)
 169              classdecls)
 170              typedecls
 171
 172         sorted_pairs = sortLt lexical_lt (bagToList name_flag_pairs)
 173
 174     in
 175     hPutStr if_hdl "\n__exports__\n" >>
 176     hPutStr if_hdl (ppShow 100 (ppAboves (map pp_pair sorted_pairs)))
 177   where
 178     from_ty (TyData _ n _ _ _ _ _) acc = maybe_add acc n
 179     from_ty (TyNew  _ n _ _ _ _ _) acc = maybe_add acc n
 180     from_ty (TySynonym n _ _ _)    acc = maybe_add acc n
 181
 182     from_cls (ClassDecl _ n _ _ _ _ _) acc = maybe_add acc n
 183
 184     from_sig (Sig n _ _ _) acc = maybe_add acc n
 185
 186     from_binds bs acc = maybe_add_list acc (collectTopLevelBinders bs)
 187
 188     --------------
 189     maybe_add :: Bag (Name, ExportFlag) -> RnName -> Bag (Name, ExportFlag)
 190
 191     maybe_add acc rn
 192       | exportFlagOn ef = acc `snocBag` (n, ef)
 193       | otherwise       = acc
 194       where
 195         n  = getName rn
 196         ef = nameExportFlag n
 197
 198     --------------
 199     maybe_add_list acc []     = acc
 200     maybe_add_list acc (n:ns) = maybe_add (maybe_add_list acc ns) n
 201
 202     --------------
 203     lexical_lt (n1,_) (n2,_) = nameOrigName n1 < nameOrigName n2
 204
 205     --------------
 206     pp_pair (n, ef)
 207       = ppBeside (ppr_name n) (pp_export ef)
 208       where
 209         pp_export ExportAll = ppPStr SLIT("(..)")
 210         pp_export ExportAbs = ppNil
 211 \end{code}
 212
 213 \begin{code}
 214 ifaceFixities Nothing{-no iface handle-} _ = return ()
 215
 216 ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _)
 217   = let
 218         local_fixities = filter from_here fixities
 219     in
 220     if null local_fixities then
 221         return ()
 222     else
 223         hPutStr if_hdl "\n__fixities__\n" >>
 224         hPutStr if_hdl (ppShow 100 (ppAboves (map ppSemid local_fixities)))
 225   where
 226     from_here (InfixL v _) = isLocallyDefined v
 227     from_here (InfixR v _) = isLocallyDefined v
 228     from_here (InfixN v _) = isLocallyDefined v
 229 \end{code}
 230
 231 \begin{code}
 232 ifaceDecls Nothing{-no iface handle-} _ = return ()
 233
 234 ifaceDecls (Just if_hdl) (vals, tycons, classes, _)
 235   = let
 236         exported_classes = filter isExported classes
 237         exported_tycons  = filter isExported tycons
 238         exported_vals    = filter isExported vals
 239
 240         sorted_classes   = sortLt ltLexical exported_classes
 241         sorted_tycons    = sortLt ltLexical exported_tycons
 242         sorted_vals      = sortLt ltLexical exported_vals
 243     in
 244     ASSERT(not (null exported_classes && null exported_tycons && null exported_vals))
 245
 246     hPutStr if_hdl "\n__declarations__\n" >>
 247     hPutStr if_hdl (ppShow 100 (ppAboves [
 248         ppAboves (map ppr_class sorted_classes),
 249         ppAboves (map ppr_tycon sorted_tycons),
 250         ppAboves [ppr_val v (idType v) | v <- sorted_vals]]))
 251 \end{code}
 252
 253 \begin{code}
 254 ifaceInstances Nothing{-no iface handle-} _ = return ()
 255
 256 ifaceInstances (Just if_hdl) (_, _, _, insts)
 257   = let
 258         exported_insts  = filter is_exported_inst (bagToList insts)
 259
 260         sorted_insts    = sortLt lt_inst exported_insts
 261     in
 262     if null exported_insts then
 263         return ()
 264     else
 265         hPutStr if_hdl "\n__instances__\n" >>
 266         hPutStr if_hdl (ppShow 100 (ppAboves (map pp_inst sorted_insts)))
 267   where
 268     is_exported_inst (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
 269       = from_here -- && ...
 270
 271     -------
 272     lt_inst (InstInfo clas1 _ ty1 _ _ _ _ _ _ _ _ _)
 273             (InstInfo clas2 _ ty2 _ _ _ _ _ _ _ _ _)
 274       = let
 275             tycon1 = fst (getAppTyCon ty1)
 276             tycon2 = fst (getAppTyCon ty2)
 277         in
 278         case (origName clas1 `cmp` origName clas2) of
 279           LT_ -> True
 280           GT_ -> False
 281           EQ_ -> origName tycon1 < origName tycon2
 282
 283     -------
 284     pp_inst (InstInfo clas tvs ty theta _ _ _ _ _ _ _ _)
 285       = let
 286             forall_ty     = mkSigmaTy tvs theta (mkDictTy clas ty)
 287             renumbered_ty = initNmbr (nmbrType forall_ty)
 288         in
 289         ppBesides [ppPStr SLIT("instance "), ppr_ty renumbered_ty, ppSemi]
 290 \end{code}
 291
 292 %************************************************************************
 293 %*                                                                      *
 294 \subsection{Printing tycons, classes, ...}
 295 %*                                                                      *
 296 %************************************************************************
 297
 298 \begin{code}
 299 ppr_class :: Class -> Pretty
 300
 301 ppr_class c
 302   = --pprTrace "ppr_class:" (ppr PprDebug c) $
 303     case (initNmbr (nmbrClass c)) of { -- renumber it!
 304       Class _ n tyvar super_classes sdsels ops sels defms insts links ->
 305
 306         ppAbove (ppCat [ppPStr SLIT("class"), ppr_theta tyvar super_classes,
 307                     ppr_name n, ppr_tyvar tyvar,
 308                     if null ops then ppSemi else ppStr "where {"])
 309             (if (null ops)
 310              then ppNil
 311              else ppAbove (ppNest 2 (ppAboves (map ppr_op ops)))
 312                           (ppStr "};")
 313             )
 314     }
 315   where
 316     ppr_theta :: TyVar -> [Class] -> Pretty
 317
 318     ppr_theta tv []   = ppNil
 319     ppr_theta tv [sc] = ppBeside (ppr_assert tv sc) (ppStr " =>")
 320     ppr_theta tv super_classes
 321       = ppBesides [ppLparen,
 322                    ppIntersperse pp'SP{-'-} (map (ppr_assert tv) super_classes),
 323                    ppStr ") =>"]
 324
 325     ppr_assert tv (Class _ n _ _ _ _ _ _ _ _) = ppCat [ppr_name n, ppr_tyvar tv]
 326
 327     ppr_op (ClassOp o _ ty) = pp_sig (Unqual o) ty
 328 \end{code}
 329
 330 \begin{code}
 331 ppr_val v ty -- renumber the type first!
 332   = --pprTrace "ppr_val:" (ppr PprDebug v) $
 333     pp_sig v (initNmbr (nmbrType ty))
 334
 335 pp_sig op ty
 336   = ppBesides [ppr_name op, ppPStr SLIT(" :: "), ppr_ty ty, ppSemi]
 337 \end{code}
 338
 339 \begin{code}
 340 ppr_tycon tycon
 341   = --pprTrace "ppr_tycon:" (ppr PprDebug tycon) $
 342     ppr_tc (initNmbr (nmbrTyCon tycon))
 343
 344 ------------------------
 345 ppr_tc (PrimTyCon _ n _)
 346   = ppCat [ ppStr "{- data", ppr_name n, ppStr " *built-in* -}" ]
 347
 348 ppr_tc FunTyCon
 349   = ppCat [ ppStr "{- data", ppr_name FunTyCon, ppStr " *built-in* -}" ]
 350
 351 ppr_tc (TupleTyCon _ n _)
 352   = ppCat [ ppStr "{- ", ppr_name n, ppStr "-}" ]
 353
 354 ppr_tc (SynTyCon _ n _ _ tvs expand)
 355   = let
 356         pp_tyvars   = map ppr_tyvar tvs
 357     in
 358     ppBesides [ppPStr SLIT("type "), ppr_name n, ppSP, ppIntersperse ppSP pp_tyvars,
 359            ppPStr SLIT(" = "), ppr_ty expand, ppSemi]
 360
 361 ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new)
 362   = ppHang (ppCat [pp_data_or_new,
 363                    ppr_context ctxt,
 364                    ppr_name n,
 365                    ppIntersperse ppSP (map ppr_tyvar tvs)])
 366            2
 367            (ppBeside pp_unabstract_condecls ppSemi)
 368            -- NB: we do not print deriving info in interfaces
 369   where
 370     pp_data_or_new = case data_or_new of
 371                       DataType -> ppPStr SLIT("data")
 372                       NewType  -> ppPStr SLIT("newtype")
 373
 374     ppr_context []      = ppNil
 375     ppr_context [(c,t)] = ppCat [ppr_name c, ppr_ty t, ppStr "=>"]
 376     ppr_context cs
 377       = ppBesides[ppLparen,
 378                   ppInterleave ppComma [ppCat [ppr_name c, ppr_ty t] | (c,t) <- cs],
 379                   ppRparen, ppStr " =>"]
 380
 381     yes_we_print_condecls
 382       = case (getExportFlag n) of
 383           ExportAbs -> False
 384           other     -> True
 385
 386     pp_unabstract_condecls
 387       = if yes_we_print_condecls
 388         then ppCat [ppEquals, pp_condecls]
 389         else ppNil
 390
 391     pp_condecls
 392       = let
 393             (c:cs) = cons
 394         in
 395         ppSep ((ppr_con c) : (map ppr_next_con cs))
 396
 397     ppr_next_con con = ppCat [ppChar '|', ppr_con con]
 398
 399     ppr_con con
 400       = let
 401             (_, _, con_arg_tys, _) = dataConSig con
 402             labels       = dataConFieldLabels con -- none if not a record
 403             strict_marks = dataConStrictMarks con
 404         in
 405         ppCat [ppr_unq_name con, ppr_fields labels strict_marks con_arg_tys]
 406
 407     ppr_fields labels strict_marks con_arg_tys
 408       = if null labels then -- not a record thingy
 409             ppIntersperse ppSP (zipWithEqual  ppr_bang_ty strict_marks con_arg_tys)
 410         else
 411             ppCat [ ppChar '{',
 412             ppInterleave ppComma (zipWith3Equal ppr_field labels strict_marks con_arg_tys),
 413             ppChar '}' ]
 414
 415     ppr_bang_ty b t
 416       = ppBeside (case b of { MarkedStrict -> ppChar '!'; _ -> ppNil })
 417                  (pprParendType PprInterface t)
 418
 419     ppr_field l b t
 420       = ppBesides [ppr_unq_name l, ppPStr SLIT(" :: "),
 421                    case b of { MarkedStrict -> ppChar '!'; _ -> ppNil },
 422                    ppr_ty t]
 423 \end{code}