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 FiniteMap        ( fmToList )
  28 import HsSyn
  29 import Id               ( idType, dataConSig, dataConFieldLabels,
  30                           dataConStrictMarks, StrictnessMark(..),
  31                           GenId{-instance NamedThing/Outputable-}
  32                         )
  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-}
  39                         )
  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-} )
  51
  52 ppSemid    x = ppBeside (ppr PprInterface x) ppSemi -- micro util
  53 ppr_ty    ty = pprType PprInterface ty
  54 ppr_tyvar tv = ppr PprInterface tv
  55 ppr_name   n
  56   = let
  57         on = origName n
  58         s  = nameOf  on
  59         pp = ppr PprInterface on
  60     in
  61     (if isLexSym s then ppParens else id) pp
  62 ppr_unq_name n
  63   = let
  64         on = origName n
  65         s  = nameOf  on
  66         pp = ppPStr   s
  67     in
  68     (if isLexSym s then ppParens else id) pp
  69 \end{code}
  70
  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.
  74
  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@.
  78
  79 \begin{code}
  80 startIface  :: Module
  81             -> IO (Maybe Handle) -- Nothing <=> don't do an interface
  82 endIface    :: Maybe Handle -> IO ()
  83 ifaceUsages
  84             :: Maybe Handle
  85             -> UsagesMap
  86             -> IO ()
  87 ifaceVersions
  88             :: Maybe Handle
  89             -> VersionsMap
  90             -> IO ()
  91 ifaceExportList
  92             :: Maybe Handle
  93             -> RenamedHsModule
  94             -> IO ()
  95 ifaceFixities
  96             :: Maybe Handle
  97             -> RenamedHsModule
  98             -> IO ()
  99 ifaceInstanceModules
 100             :: Maybe Handle
 101             -> [Module]
 102             -> IO ()
 103 ifaceDecls  :: Maybe Handle
 104             -> TcIfaceInfo  -- info produced by typechecker, for interfaces
 105             -> IO ()
 106 ifaceInstances
 107             :: Maybe Handle
 108             -> TcIfaceInfo  -- as above
 109             -> IO ()
 110 ifacePragmas
 111             :: Maybe Handle
 112             -> IO ()
 113 ifacePragmas = panic "ifacePragmas" -- stub
 114 \end{code}
 115
 116 \begin{code}
 117 startIface mod
 118   = case opt_ProduceHi of
 119       Nothing -> return Nothing -- not producing any .hi file
 120       Just fn ->
 121         openFile fn WriteMode   >>= \ if_hdl ->
 122         hPutStr if_hdl ("interface "++ _UNPK_ mod ++" 1\n") >>
 123         return (Just if_hdl)
 124
 125 endIface Nothing        = return ()
 126 endIface (Just if_hdl)  = hPutStr if_hdl "\n" >> hClose if_hdl
 127 \end{code}
 128
 129 \begin{code}
 130 ifaceUsages Nothing{-no iface handle-} _ = return ()
 131
 132 ifaceUsages (Just if_hdl) usages
 133   | null usages_list
 134   = return ()
 135   | otherwise
 136   = hPutStr if_hdl "__usages__\n"   >>
 137     hPutStr if_hdl (ppShow 10000 (ppAboves (map pp_uses usages_list)))
 138   where
 139     usages_list = fmToList usages
 140
 141     pp_uses (m, (mv, versions))
 142       = ppBesides [ppPStr m, ppSP, ppInt mv, ppPStr SLIT(" :: "),
 143                pp_versions (fmToList versions), ppSemi]
 144 \end{code}
 145
 146 \begin{code}
 147 ifaceVersions Nothing{-no iface handle-} _ = return ()
 148
 149 ifaceVersions (Just if_hdl) version_info
 150   | null version_list
 151   = return ()
 152   | otherwise
 153   = hPutStr if_hdl "\n__versions__\n"   >>
 154     hPutStr if_hdl (ppShow 10000 (pp_versions version_list))
 155   where
 156     version_list = fmToList version_info
 157
 158 pp_versions nvs
 159   = ppInterleave ppComma [ ppCat [ppPStr n, ppInt v] | (n,v) <- nvs ]
 160 \end{code}
 161
 162 \begin{code}
 163 ifaceInstanceModules Nothing{-no iface handle-} _ = return ()
 164 ifaceInstanceModules (Just _)                  [] = return ()
 165
 166 ifaceInstanceModules (Just if_hdl) imods
 167   = hPutStr if_hdl "\n__instance_modules__\n" >>
 168     hPutStr if_hdl (ppShow 100 (ppCat (map ppPStr imods)))
 169 \end{code}
 170
 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.
 176 \begin{code}
 177 ifaceExportList Nothing{-no iface handle-} _ = return ()
 178
 179 ifaceExportList (Just if_hdl)
 180                 (HsModule _ _ _ _ _ typedecls _ classdecls _ _ _ binds sigs _)
 181   = let
 182         name_flag_pairs :: Bag (Name, ExportFlag)
 183         name_flag_pairs
 184           = foldr from_ty
 185            (foldr from_cls
 186            (foldr from_sig
 187            (from_binds binds emptyBag{-init accum-})
 188              sigs)
 189              classdecls)
 190              typedecls
 191
 192         sorted_pairs = sortLt lexical_lt (bagToList name_flag_pairs)
 193
 194     in
 195     hPutStr if_hdl "\n__exports__\n" >>
 196     hPutStr if_hdl (ppShow 100 (ppAboves (map pp_pair sorted_pairs)))
 197   where
 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
 201
 202     from_cls (ClassDecl _ n _ _ _ _ _) acc = maybe_add acc n
 203
 204     from_sig (Sig n _ _ _) acc = maybe_add acc n
 205
 206     from_binds bs acc = maybe_add_list acc (collectTopLevelBinders bs)
 207
 208     --------------
 209     maybe_add :: Bag (Name, ExportFlag) -> RnName -> Bag (Name, ExportFlag)
 210
 211     maybe_add acc rn
 212       | exportFlagOn ef = acc `snocBag` (n, ef)
 213       | otherwise       = acc
 214       where
 215         n  = getName rn
 216         ef = nameExportFlag n
 217
 218     --------------
 219     maybe_add_list acc []     = acc
 220     maybe_add_list acc (n:ns) = maybe_add (maybe_add_list acc ns) n
 221
 222     --------------
 223     lexical_lt (n1,_) (n2,_) = nameOrigName n1 < nameOrigName n2
 224
 225     --------------
 226     pp_pair (n, ef)
 227       = ppBeside (ppr_name n) (pp_export ef)
 228       where
 229         pp_export ExportAll = ppPStr SLIT("(..)")
 230         pp_export ExportAbs = ppNil
 231 \end{code}
 232
 233 \begin{code}
 234 ifaceFixities Nothing{-no iface handle-} _ = return ()
 235
 236 ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _)
 237   = let
 238         local_fixities = filter from_here fixities
 239     in
 240     if null local_fixities then
 241         return ()
 242     else
 243         hPutStr if_hdl "\n__fixities__\n" >>
 244         hPutStr if_hdl (ppShow 100 (ppAboves (map ppSemid local_fixities)))
 245   where
 246     from_here (InfixL v _) = isLocallyDefined v
 247     from_here (InfixR v _) = isLocallyDefined v
 248     from_here (InfixN v _) = isLocallyDefined v
 249 \end{code}
 250
 251 \begin{code}
 252 ifaceDecls Nothing{-no iface handle-} _ = return ()
 253
 254 ifaceDecls (Just if_hdl) (vals, tycons, classes, _)
 255   = let
 256         exported_classes = filter isExported classes
 257         exported_tycons  = filter isExported tycons
 258         exported_vals    = filter isExported vals
 259
 260         sorted_classes   = sortLt ltLexical exported_classes
 261         sorted_tycons    = sortLt ltLexical exported_tycons
 262         sorted_vals      = sortLt ltLexical exported_vals
 263     in
 264     ASSERT(not (null exported_classes && null exported_tycons && null exported_vals))
 265
 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]]))
 271 \end{code}
 272
 273 \begin{code}
 274 ifaceInstances Nothing{-no iface handle-} _ = return ()
 275
 276 ifaceInstances (Just if_hdl) (_, _, _, insts)
 277   = let
 278         exported_insts  = filter is_exported_inst (bagToList insts)
 279
 280         sorted_insts    = sortLt lt_inst exported_insts
 281     in
 282     if null exported_insts then
 283         return ()
 284     else
 285         hPutStr if_hdl "\n__instances__\n" >>
 286         hPutStr if_hdl (ppShow 100 (ppAboves (map pp_inst sorted_insts)))
 287   where
 288     is_exported_inst (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
 289       = from_here -- && ...
 290
 291     -------
 292     lt_inst (InstInfo clas1 _ ty1 _ _ _ _ _ _ _ _ _)
 293             (InstInfo clas2 _ ty2 _ _ _ _ _ _ _ _ _)
 294       = let
 295             tycon1 = fst (getAppTyCon ty1)
 296             tycon2 = fst (getAppTyCon ty2)
 297         in
 298         case (origName clas1 `cmp` origName clas2) of
 299           LT_ -> True
 300           GT_ -> False
 301           EQ_ -> origName tycon1 < origName tycon2
 302
 303     -------
 304     pp_inst (InstInfo clas tvs ty theta _ _ _ _ _ _ _ _)
 305       = let
 306             forall_ty     = mkSigmaTy tvs theta (mkDictTy clas ty)
 307             renumbered_ty = initNmbr (nmbrType forall_ty)
 308         in
 309         ppBesides [ppPStr SLIT("instance "), ppr_ty renumbered_ty, ppSemi]
 310 \end{code}
 311
 312 %************************************************************************
 313 %*                                                                      *
 314 \subsection{Printing tycons, classes, ...}
 315 %*                                                                      *
 316 %************************************************************************
 317
 318 \begin{code}
 319 ppr_class :: Class -> Pretty
 320
 321 ppr_class c
 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 ->
 325
 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 {"])
 329             (if (null ops)
 330              then ppNil
 331              else ppAbove (ppNest 2 (ppAboves (map ppr_op ops)))
 332                           (ppStr "};")
 333             )
 334     }
 335   where
 336     ppr_theta :: TyVar -> [Class] -> Pretty
 337
 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),
 343                    ppStr ") =>"]
 344
 345     ppr_assert tv (Class _ n _ _ _ _ _ _ _ _) = ppCat [ppr_name n, ppr_tyvar tv]
 346
 347     ppr_op (ClassOp o _ ty) = pp_sig (Unqual o) ty
 348 \end{code}
 349
 350 \begin{code}
 351 ppr_val v ty -- renumber the type first!
 352   = --pprTrace "ppr_val:" (ppr PprDebug v) $
 353     pp_sig v (initNmbr (nmbrType ty))
 354
 355 pp_sig op ty
 356   = ppBesides [ppr_name op, ppPStr SLIT(" :: "), ppr_ty ty, ppSemi]
 357 \end{code}
 358
 359 \begin{code}
 360 ppr_tycon tycon
 361   = --pprTrace "ppr_tycon:" (ppr PprDebug tycon) $
 362     ppr_tc (initNmbr (nmbrTyCon tycon))
 363
 364 ------------------------
 365 ppr_tc (PrimTyCon _ n _)
 366   = ppCat [ ppStr "{- data", ppr_name n, ppStr " *built-in* -}" ]
 367
 368 ppr_tc FunTyCon
 369   = ppCat [ ppStr "{- data", ppr_name FunTyCon, ppStr " *built-in* -}" ]
 370
 371 ppr_tc (TupleTyCon _ n _)
 372   = ppCat [ ppStr "{- ", ppr_name n, ppStr "-}" ]
 373
 374 ppr_tc (SynTyCon _ n _ _ tvs expand)
 375   = let
 376         pp_tyvars   = map ppr_tyvar tvs
 377     in
 378     ppBesides [ppPStr SLIT("type "), ppr_name n, ppSP, ppIntersperse ppSP pp_tyvars,
 379            ppPStr SLIT(" = "), ppr_ty expand, ppSemi]
 380
 381 ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new)
 382   = ppHang (ppCat [pp_data_or_new,
 383                    ppr_context ctxt,
 384                    ppr_name n,
 385                    ppIntersperse ppSP (map ppr_tyvar tvs)])
 386            2
 387            (ppBeside pp_unabstract_condecls ppSemi)
 388            -- NB: we do not print deriving info in interfaces
 389   where
 390     pp_data_or_new = case data_or_new of
 391                       DataType -> ppPStr SLIT("data")
 392                       NewType  -> ppPStr SLIT("newtype")
 393
 394     ppr_context []      = ppNil
 395     ppr_context [(c,t)] = ppCat [ppr_name c, ppr_ty t, ppStr "=>"]
 396     ppr_context cs
 397       = ppBesides[ppLparen,
 398                   ppInterleave ppComma [ppCat [ppr_name c, ppr_ty t] | (c,t) <- cs],
 399                   ppRparen, ppStr " =>"]
 400
 401     yes_we_print_condecls
 402       = case (getExportFlag n) of
 403           ExportAbs -> False
 404           other     -> True
 405
 406     pp_unabstract_condecls
 407       = if yes_we_print_condecls
 408         then ppCat [ppEquals, pp_condecls]
 409         else ppNil
 410
 411     pp_condecls
 412       = let
 413             (c:cs) = cons
 414         in
 415         ppSep ((ppr_con c) : (map ppr_next_con cs))
 416
 417     ppr_next_con con = ppCat [ppChar '|', ppr_con con]
 418
 419     ppr_con con
 420       = let
 421             (_, _, con_arg_tys, _) = dataConSig con
 422             labels       = dataConFieldLabels con -- none if not a record
 423             strict_marks = dataConStrictMarks con
 424         in
 425         ppCat [ppr_unq_name con, ppr_fields labels strict_marks con_arg_tys]
 426
 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)
 430         else
 431             ppCat [ ppChar '{',
 432             ppInterleave ppComma (zipWith3Equal ppr_field labels strict_marks con_arg_tys),
 433             ppChar '}' ]
 434
 435     ppr_bang_ty b t
 436       = ppBeside (case b of { MarkedStrict -> ppChar '!'; _ -> ppNil })
 437                  (pprParendType PprInterface t)
 438
 439     ppr_field l b t
 440       = ppBesides [ppr_unq_name l, ppPStr SLIT(" :: "),
 441                    case b of { MarkedStrict -> ppChar '!'; _ -> ppNil },
 442                    ppr_ty t]
 443 \end{code}