ghc/compiler/main/MkIface.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
   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 IMP_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, eltsFM )
  28 import HsSyn
  29 import Id               ( idType, dataConRawArgTys, dataConFieldLabels,
  30                           dataConStrictMarks, StrictnessMark(..),
  31                           GenId{-instance NamedThing/Outputable-}
  32                         )
  33 import Name             ( origName, nameOf, moduleOf,
  34                           exportFlagOn, nameExportFlag, ExportFlag(..),
  35                           isLexSym, isLocallyDefined, isWiredInName,
  36                           RdrName(..){-instance Outputable-},
  37                           OrigName(..){-instance Ord-},
  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 PrelMods       ( modulesWithBuiltins )
  45 import PrelInfo         ( builtinNameInfo )
  46 import Pretty           ( prettyToUn )
  47 import Unpretty         -- ditto
  48 import RnHsSyn          ( RenamedHsModule(..), RnName{-instance NamedThing-} )
  49 import TcModule         ( TcIfaceInfo(..) )
  50 import TcInstUtil       ( InstInfo(..) )
  51 import TyCon            ( TyCon(..){-instance NamedThing-}, NewOrData(..) )
  52 import Type             ( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy )
  53 import Util             ( sortLt, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}, pprTrace{-ToDo:rm-} )
  54
  55 uppSemid   x = uppBeside (prettyToUn (ppr PprInterface x)) uppSemi -- micro util
  56 ppr_ty    ty = prettyToUn (pprType PprInterface ty)
  57 ppr_tyvar tv = prettyToUn (ppr PprInterface tv)
  58 ppr_name   n
  59   = case (origName "ppr_name" n) of { OrigName m s ->
  60     uppBesides [uppPStr m, uppChar '.', uppPStr s] }
  61 \end{code}
  62
  63 We have a function @startIface@ to open the output file and put
  64 (something like) ``interface Foo'' in it.  It gives back a handle
  65 for subsequent additions to the interface file.
  66
  67 We then have one-function-per-block-of-interface-stuff, e.g.,
  68 @ifaceExportList@ produces the @__exports__@ section; it appends
  69 to the handle provided by @startIface@.
  70
  71 \begin{code}
  72 startIface  :: Module
  73             -> IO (Maybe Handle) -- Nothing <=> don't do an interface
  74 endIface    :: Maybe Handle -> IO ()
  75 ifaceUsages
  76             :: Maybe Handle
  77             -> UsagesMap
  78             -> IO ()
  79 ifaceVersions
  80             :: Maybe Handle
  81             -> VersionsMap
  82             -> IO ()
  83 ifaceExportList
  84             :: Maybe Handle
  85             -> (Name -> ExportFlag)
  86             -> RenamedHsModule
  87             -> IO ()
  88 ifaceFixities
  89             :: Maybe Handle
  90             -> RenamedHsModule
  91             -> IO ()
  92 ifaceInstanceModules
  93             :: Maybe Handle
  94             -> [Module]
  95             -> IO ()
  96 ifaceDecls  :: Maybe Handle
  97             -> TcIfaceInfo  -- info produced by typechecker, for interfaces
  98             -> IO ()
  99 ifaceInstances
 100             :: Maybe Handle
 101             -> TcIfaceInfo  -- as above
 102             -> IO ()
 103 ifacePragmas
 104             :: Maybe Handle
 105             -> IO ()
 106 ifacePragmas = panic "ifacePragmas" -- stub
 107 \end{code}
 108
 109 \begin{code}
 110 startIface mod
 111   = case opt_ProduceHi of
 112       Nothing -> return Nothing -- not producing any .hi file
 113       Just fn ->
 114         openFile fn WriteMode   >>= \ if_hdl ->
 115         hPutStr if_hdl ("interface "++ _UNPK_ mod) >>
 116         return (Just if_hdl)
 117
 118 endIface Nothing        = return ()
 119 endIface (Just if_hdl)  = hPutStr if_hdl "\n" >> hClose if_hdl
 120 \end{code}
 121
 122 \begin{code}
 123 ifaceUsages Nothing{-no iface handle-} _ = return ()
 124
 125 ifaceUsages (Just if_hdl) usages
 126   | null usages_list
 127   = return ()
 128   | otherwise
 129   = hPutStr if_hdl "\n__usages__\n"   >>
 130     hPutStr if_hdl (uppShow 0 (uppAboves (map upp_uses usages_list)))
 131   where
 132     usages_list = fmToList usages -- NO: filter has_no_builtins (...)
 133
 134 --  has_no_builtins (m, _)
 135 --    = m `notElem` modulesWithBuiltins
 136 --    -- Don't *have* to do this; save gratuitous spillage in
 137 --    -- every interface.  Could be flag-controlled...
 138
 139     upp_uses (m, (mv, versions))
 140       = uppBesides [uppPStr m, uppSP, uppInt mv, uppPStr SLIT(" :: "),
 141                upp_versions (fmToList versions), uppSemi]
 142
 143     upp_versions nvs
 144       = uppIntersperse uppSP [ uppCat [uppPStr n, uppInt v] | (n,v) <- nvs ]
 145 \end{code}
 146
 147 \begin{code}
 148 ifaceVersions Nothing{-no iface handle-} _ = return ()
 149
 150 ifaceVersions (Just if_hdl) version_info
 151   | null version_list
 152   = return ()
 153   | otherwise
 154   = hPutStr if_hdl "\n__versions__\n"   >>
 155     hPutStr if_hdl (uppShow 0 (upp_versions version_list))
 156     -- NB: when compiling Prelude.hs, this will spew out
 157     -- stuff for [], (), (,), etc. [i.e., builtins], which
 158     -- we'd rather it didn't.  The version-mangling in
 159     -- the driver will ignore them.
 160   where
 161     version_list = fmToList version_info
 162
 163     upp_versions nvs
 164       = uppAboves [ uppPStr n | (n,v) <- nvs ]
 165 \end{code}
 166
 167 \begin{code}
 168 ifaceInstanceModules Nothing{-no iface handle-} _ = return ()
 169 ifaceInstanceModules (Just _)                  [] = return ()
 170
 171 ifaceInstanceModules (Just if_hdl) imods
 172   = hPutStr if_hdl "\n__instance_modules__\n" >>
 173     hPutStr if_hdl (uppShow 0 (uppCat (map uppPStr imods)))
 174 \end{code}
 175
 176 Export list: grab the Names of things that are marked Exported, sort
 177 (so the interface file doesn't ``wobble'' from one compilation to the
 178 next...), and print.  Note that the ``module'' now contains all the
 179 imported things that we are dealing with, thus including any entities
 180 that we are re-exporting from somewhere else.
 181 \begin{code}
 182 ifaceExportList Nothing{-no iface handle-} _ _ = return ()
 183
 184 ifaceExportList (Just if_hdl)
 185                 export_fn -- sadly, just the HsModule isn't enough,
 186                           -- because it will have no record of exported
 187                           -- wired-in names.
 188                 (HsModule _ _ _ _ _ typedecls _ classdecls _ _ _ binds sigs _)
 189   = let
 190         (vals_wired, tcs_wired)
 191           = case builtinNameInfo of { ((vals_fm,tcs_fm), _, _) ->
 192             ([ getName rn | rn <- eltsFM vals_fm ]
 193             ,[ getName rn | rn <- eltsFM tcs_fm  ]) }
 194
 195         name_flag_pairs :: Bag (OrigName, ExportFlag)
 196         name_flag_pairs
 197           = foldr from_wired
 198            (foldr from_wired
 199            (foldr from_ty
 200            (foldr from_cls
 201            (foldr from_sig
 202            (from_binds binds emptyBag{-init accum-})
 203              sigs)
 204              classdecls)
 205              typedecls)
 206              tcs_wired)
 207              vals_wired
 208
 209         sorted_pairs = sortLt lexical_lt (bagToList name_flag_pairs)
 210
 211     in
 212     hPutStr if_hdl "\n__exports__\n" >>
 213     hPutStr if_hdl (uppShow 0 (uppAboves (map upp_pair sorted_pairs)))
 214   where
 215     from_ty (TyData _ n _ _ _ _ _) acc = maybe_add acc n
 216     from_ty (TyNew  _ n _ _ _ _ _) acc = maybe_add acc n
 217     from_ty (TySynonym n _ _ _)    acc = maybe_add acc n
 218
 219     from_cls (ClassDecl _ n _ _ _ _ _) acc = maybe_add acc n
 220
 221     from_sig (Sig n _ _ _) acc = maybe_add acc n
 222
 223     from_binds bs acc = maybe_add_list acc (collectTopLevelBinders bs)
 224
 225     --------------
 226     from_wired n acc
 227       | exportFlagOn ef = acc `snocBag` (origName "maybe_add" n, ef)
 228       | otherwise       = acc
 229       where
 230         ef = export_fn n
 231
 232     --------------
 233     maybe_add :: Bag (OrigName, ExportFlag) -> RnName -> Bag (OrigName, ExportFlag)
 234
 235     maybe_add acc rn
 236       | exportFlagOn ef = acc `snocBag` (origName "maybe_add" n, ef)
 237       | otherwise       = acc
 238       where
 239         n  = getName rn
 240         ef = nameExportFlag n
 241
 242     --------------
 243     maybe_add_list acc []     = acc
 244     maybe_add_list acc (n:ns) = maybe_add (maybe_add_list acc ns) n
 245
 246     --------------
 247     lexical_lt (n1,_) (n2,_) = n1 < n2
 248
 249     --------------
 250     upp_pair (OrigName m n, ef)
 251       = uppBesides [uppPStr m, uppSP, uppPStr n, uppSP, upp_export ef]
 252       where
 253         upp_export ExportAll = uppPStr SLIT("(..)")
 254         upp_export ExportAbs = uppNil
 255 \end{code}
 256
 257 \begin{code}
 258 ifaceFixities Nothing{-no iface handle-} _ = return ()
 259
 260 ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _)
 261   = let
 262         pp_fixities = foldr go [] fixities
 263     in
 264     if null pp_fixities then
 265         return ()
 266     else
 267         hPutStr if_hdl "\n__fixities__\n" >>
 268         hPutStr if_hdl (uppShow 0 (uppAboves pp_fixities))
 269   where
 270     go (InfixL v i) acc = (if isLocallyDefined v then (:) (print_fix "l" i v) else id) acc
 271     go (InfixR v i) acc = (if isLocallyDefined v then (:) (print_fix "r" i v) else id) acc
 272     go (InfixN v i) acc = (if isLocallyDefined v then (:) (print_fix ""  i v) else id) acc
 273
 274     print_fix suff prec var
 275       = uppBesides [uppPStr SLIT("infix"), uppStr suff, uppSP, uppInt prec, uppSP, ppr_name var, uppSemi]
 276 \end{code}
 277
 278 \begin{code}
 279 non_wired x = not (isWiredInName (getName x)) --ToDo:move?
 280
 281 ifaceDecls Nothing{-no iface handle-} _ = return ()
 282
 283 ifaceDecls (Just if_hdl) (vals, tycons, classes, _)
 284   = ASSERT(all isLocallyDefined vals)
 285     ASSERT(all isLocallyDefined tycons)
 286     ASSERT(all isLocallyDefined classes)
 287     let
 288         nonwired_classes = filter non_wired classes
 289         nonwired_tycons  = filter non_wired tycons
 290         nonwired_vals    = filter non_wired vals
 291
 292         lt_lexical a b = origName "lt_lexical" a < origName "lt_lexical" b
 293
 294         sorted_classes = sortLt lt_lexical nonwired_classes
 295         sorted_tycons  = sortLt lt_lexical nonwired_tycons
 296         sorted_vals    = sortLt lt_lexical nonwired_vals
 297     in
 298     if (null sorted_classes && null sorted_tycons && null sorted_vals) then
 299         --  You could have a module with just (re-)exports/instances in it
 300         return ()
 301     else
 302     hPutStr if_hdl "\n__declarations__\n" >>
 303     hPutStr if_hdl (uppShow 0 (uppAboves [
 304         uppAboves (map ppr_class sorted_classes),
 305         uppAboves (map ppr_tycon sorted_tycons),
 306         uppAboves [ppr_val v (idType v) | v <- sorted_vals]]))
 307 \end{code}
 308
 309 \begin{code}
 310 ifaceInstances Nothing{-no iface handle-} _ = return ()
 311
 312 ifaceInstances (Just if_hdl) (_, _, _, insts)
 313   = let
 314         togo_insts      = filter is_togo_inst (bagToList insts)
 315
 316         sorted_insts    = sortLt lt_inst togo_insts
 317     in
 318     if null togo_insts then
 319         return ()
 320     else
 321         hPutStr if_hdl "\n__instances__\n" >>
 322         hPutStr if_hdl (uppShow 0 (uppAboves (map pp_inst sorted_insts)))
 323   where
 324     is_togo_inst (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
 325       = from_here -- && ...
 326
 327     -------
 328     lt_inst (InstInfo clas1 _ ty1 _ _ _ _ _ _ _ _ _)
 329             (InstInfo clas2 _ ty2 _ _ _ _ _ _ _ _ _)
 330       = let
 331             tycon1 = fst (getAppTyCon ty1)
 332             tycon2 = fst (getAppTyCon ty2)
 333         in
 334         case (origName "lt_inst" clas1 `cmp` origName "lt_inst" clas2) of
 335           LT_ -> True
 336           GT_ -> False
 337           EQ_ -> origName "lt_inst2" tycon1 < origName "lt_inst2" tycon2
 338
 339     -------
 340     pp_inst (InstInfo clas tvs ty theta _ _ _ _ _ _ _ _)
 341       = let
 342             forall_ty     = mkSigmaTy tvs theta (mkDictTy clas ty)
 343             renumbered_ty = initNmbr (nmbrType forall_ty)
 344         in
 345         case (splitForAllTy renumbered_ty) of { (rtvs, rrho_ty) ->
 346         uppBesides [uppPStr SLIT("instance "), ppr_forall rtvs, ppr_ty rrho_ty, uppSemi] }
 347 \end{code}
 348
 349 %************************************************************************
 350 %*                                                                      *
 351 \subsection{Printing tycons, classes, ...}
 352 %*                                                                      *
 353 %************************************************************************
 354
 355 \begin{code}
 356 ppr_class :: Class -> Unpretty
 357
 358 ppr_class c
 359   = --pprTrace "ppr_class:" (ppr PprDebug c) $
 360     case (initNmbr (nmbrClass c)) of { -- renumber it!
 361       Class _ n tyvar super_classes sdsels ops sels defms insts links ->
 362
 363         uppCat [uppPStr SLIT("class"), ppr_context tyvar super_classes,
 364                 ppr_name n, ppr_tyvar tyvar,
 365                 if null ops
 366                 then uppSemi
 367                 else uppCat [uppStr "where {", uppCat (map ppr_op ops), uppStr "};"]]
 368     }
 369   where
 370     ppr_context :: TyVar -> [Class] -> Unpretty
 371
 372     ppr_context tv []   = uppNil
 373 --  ppr_context tv [sc] = uppBeside (ppr_assert tv sc) (uppPStr SLIT(" =>"))
 374     ppr_context tv super_classes
 375       = uppBesides [uppStr "{{",
 376                     uppIntersperse upp'SP{-'-} (map (ppr_assert tv) super_classes),
 377                     uppStr "}} =>"]
 378
 379     ppr_assert tv (Class _ n _ _ _ _ _ _ _ _) = uppCat [ppr_name n, ppr_tyvar tv]
 380
 381     clas_mod = moduleOf (origName "ppr_class" c)
 382
 383     ppr_op (ClassOp o _ ty) = pp_sig (Qual clas_mod o) ty
 384 \end{code}
 385
 386 \begin{code}
 387 ppr_val v ty -- renumber the type first!
 388   = --pprTrace "ppr_val:" (ppr PprDebug v) $
 389     pp_sig v (initNmbr (nmbrType ty))
 390
 391 pp_sig op ty
 392   = case (splitForAllTy ty) of { (tvs, rho_ty) ->
 393     uppBesides [ppr_name op, uppPStr SLIT(" :: "), ppr_forall tvs, ppr_ty rho_ty, uppSemi] }
 394
 395 ppr_forall []  = uppNil
 396 ppr_forall tvs = uppBesides [ uppStr "__forall__ [", uppInterleave uppComma (map ppr_tyvar tvs), uppStr "] " ]
 397 \end{code}
 398
 399 \begin{code}
 400 ppr_tycon tycon
 401   = --pprTrace "ppr_tycon:" (ppr PprDebug tycon) $
 402     ppr_tc (initNmbr (nmbrTyCon tycon))
 403
 404 ------------------------
 405 ppr_tc (PrimTyCon _ n _ _)
 406   = uppCat [ uppStr "{- data", ppr_name n, uppStr " *built-in* -}" ]
 407
 408 ppr_tc FunTyCon
 409   = uppCat [ uppStr "{- data", ppr_name FunTyCon, uppStr " *built-in* -}" ]
 410
 411 ppr_tc (TupleTyCon _ n _)
 412   = uppCat [ uppStr "{- ", ppr_name n, uppStr "-}" ]
 413
 414 ppr_tc (SynTyCon _ n _ _ tvs expand)
 415   = let
 416         pp_tyvars   = map ppr_tyvar tvs
 417     in
 418     uppBesides [uppPStr SLIT("type "), ppr_name n, uppSP, uppIntersperse uppSP pp_tyvars,
 419            uppPStr SLIT(" = "), ppr_ty expand, uppSemi]
 420
 421 ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new)
 422   = uppCat [pp_data_or_new,
 423            ppr_context ctxt,
 424            ppr_name n,
 425            uppIntersperse uppSP (map ppr_tyvar tvs),
 426            uppEquals, pp_condecls,
 427            uppSemi]
 428            -- NB: we do not print deriving info in interfaces
 429   where
 430     pp_data_or_new = case data_or_new of
 431                       DataType -> uppPStr SLIT("data")
 432                       NewType  -> uppPStr SLIT("newtype")
 433
 434     ppr_context []      = uppNil
 435 --  ppr_context [(c,t)] = uppCat [ppr_name c, ppr_ty t, uppPStr SLIT("=>")]
 436     ppr_context cs
 437       = uppBesides[uppStr "{{",
 438                    uppInterleave uppComma [uppCat [ppr_name c, ppr_ty t] | (c,t) <- cs],
 439                    uppStr "}}", uppPStr SLIT(" =>")]
 440
 441     pp_condecls
 442       = let
 443             (c:cs) = cons
 444         in
 445         uppCat ((ppr_con c) : (map ppr_next_con cs))
 446
 447     ppr_next_con con = uppCat [uppChar '|', ppr_con con]
 448
 449     ppr_con con
 450       = let
 451             con_arg_tys  = dataConRawArgTys   con
 452             labels       = dataConFieldLabels con -- none if not a record
 453             strict_marks = dataConStrictMarks con
 454         in
 455         uppCat [ppr_name con, ppr_fields labels strict_marks con_arg_tys]
 456
 457     ppr_fields labels strict_marks con_arg_tys
 458       = if null labels then -- not a record thingy
 459             uppIntersperse uppSP (zipWithEqual  "ppr_fields" ppr_bang_ty strict_marks con_arg_tys)
 460         else
 461             uppCat [ uppChar '{',
 462             uppInterleave uppComma (zipWith3Equal "ppr_field" ppr_field labels strict_marks con_arg_tys),
 463             uppChar '}' ]
 464
 465     ppr_bang_ty b t
 466       = uppBeside (case b of { MarkedStrict -> uppChar '!'; _ -> uppNil })
 467                   (prettyToUn (pprParendType PprInterface t))
 468
 469     ppr_field l b t
 470       = uppBesides [ppr_name l, uppPStr SLIT(" :: "),
 471                    case b of { MarkedStrict -> uppChar '!'; _ -> uppNil },
 472                    ppr_ty t]
 473 \end{code}