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