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 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           ( 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-} )
  52
  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)
  56 ppr_name   n
  57   = let
  58         on = origName n
  59         s  = nameOf  on
  60         pp = prettyToUn (ppr PprInterface on)
  61     in
  62     (if isLexSym s then uppParens else id) pp
  63 ppr_unq_name n
  64   = let
  65         on = origName n
  66         s  = nameOf  on
  67         pp = uppPStr  s
  68     in
  69     (if isLexSym s then uppParens else id) pp
  70 \end{code}
  71
  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.
  75
  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@.
  79
  80 \begin{code}
  81 startIface  :: Module
  82             -> IO (Maybe Handle) -- Nothing <=> don't do an interface
  83 endIface    :: Maybe Handle -> IO ()
  84 ifaceUsages
  85             :: Maybe Handle
  86             -> UsagesMap
  87             -> IO ()
  88 ifaceVersions
  89             :: Maybe Handle
  90             -> VersionsMap
  91             -> IO ()
  92 ifaceExportList
  93             :: Maybe Handle
  94             -> RenamedHsModule
  95             -> IO ()
  96 ifaceFixities
  97             :: Maybe Handle
  98             -> RenamedHsModule
  99             -> IO ()
 100 ifaceInstanceModules
 101             :: Maybe Handle
 102             -> [Module]
 103             -> IO ()
 104 ifaceDecls  :: Maybe Handle
 105             -> TcIfaceInfo  -- info produced by typechecker, for interfaces
 106             -> IO ()
 107 ifaceInstances
 108             :: Maybe Handle
 109             -> TcIfaceInfo  -- as above
 110             -> IO ()
 111 ifacePragmas
 112             :: Maybe Handle
 113             -> IO ()
 114 ifacePragmas = panic "ifacePragmas" -- stub
 115 \end{code}
 116
 117 \begin{code}
 118 startIface mod
 119   = case opt_ProduceHi of
 120       Nothing -> return Nothing -- not producing any .hi file
 121       Just fn ->
 122         openFile fn WriteMode   >>= \ if_hdl ->
 123         hPutStr if_hdl ("interface "++ _UNPK_ mod) >>
 124         return (Just if_hdl)
 125
 126 endIface Nothing        = return ()
 127 endIface (Just if_hdl)  = hPutStr if_hdl "\n" >> hClose if_hdl
 128 \end{code}
 129
 130 \begin{code}
 131 ifaceUsages Nothing{-no iface handle-} _ = return ()
 132
 133 ifaceUsages (Just if_hdl) usages
 134   | null usages_list
 135   = return ()
 136   | otherwise
 137   = hPutStr if_hdl "\n__usages__\n"   >>
 138     hPutStr if_hdl (uppShow 0 (uppAboves (map upp_uses usages_list)))
 139   where
 140     usages_list = fmToList usages
 141
 142     upp_uses (m, (mv, versions))
 143       = uppBesides [uppPStr m, uppSP, uppInt mv, uppPStr SLIT(" :: "),
 144                upp_versions (fmToList versions), uppSemi]
 145
 146     upp_versions nvs
 147       = uppIntersperse upp'SP{-'-} [ uppCat [(if isLexSym n then uppParens else id) (uppPStr n), uppInt v] | (n,v) <- nvs ]
 148 \end{code}
 149
 150 \begin{code}
 151 ifaceVersions Nothing{-no iface handle-} _ = return ()
 152
 153 ifaceVersions (Just if_hdl) version_info
 154   | null version_list
 155   = return ()
 156   | otherwise
 157   = hPutStr if_hdl "\n__versions__\n"   >>
 158     hPutStr if_hdl (uppShow 0 (upp_versions version_list))
 159   where
 160     version_list = fmToList version_info
 161
 162     upp_versions nvs
 163       = uppAboves [ (if isLexSym n then uppParens else id) (uppPStr n) | (n,v) <- nvs ]
 164 \end{code}
 165
 166 \begin{code}
 167 ifaceInstanceModules Nothing{-no iface handle-} _ = return ()
 168 ifaceInstanceModules (Just _)                  [] = return ()
 169
 170 ifaceInstanceModules (Just if_hdl) imods
 171   = hPutStr if_hdl "\n__instance_modules__\n" >>
 172     hPutStr if_hdl (uppShow 0 (uppCat (map uppPStr imods)))
 173 \end{code}
 174
 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.
 180 \begin{code}
 181 ifaceExportList Nothing{-no iface handle-} _ = return ()
 182
 183 ifaceExportList (Just if_hdl)
 184                 (HsModule _ _ _ _ _ typedecls _ classdecls _ _ _ binds sigs _)
 185   = let
 186         name_flag_pairs :: Bag (Name, ExportFlag)
 187         name_flag_pairs
 188           = foldr from_ty
 189            (foldr from_cls
 190            (foldr from_sig
 191            (from_binds binds emptyBag{-init accum-})
 192              sigs)
 193              classdecls)
 194              typedecls
 195
 196         sorted_pairs = sortLt lexical_lt (bagToList name_flag_pairs)
 197
 198     in
 199     hPutStr if_hdl "\n__exports__\n" >>
 200     hPutStr if_hdl (uppShow 0 (uppAboves (map upp_pair sorted_pairs)))
 201   where
 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
 205
 206     from_cls (ClassDecl _ n _ _ _ _ _) acc = maybe_add acc n
 207
 208     from_sig (Sig n _ _ _) acc = maybe_add acc n
 209
 210     from_binds bs acc = maybe_add_list acc (collectTopLevelBinders bs)
 211
 212     --------------
 213     maybe_add :: Bag (Name, ExportFlag) -> RnName -> Bag (Name, ExportFlag)
 214
 215     maybe_add acc rn
 216       | exportFlagOn ef = acc `snocBag` (n, ef)
 217       | otherwise       = acc
 218       where
 219         n  = getName rn
 220         ef = nameExportFlag n
 221
 222     --------------
 223     maybe_add_list acc []     = acc
 224     maybe_add_list acc (n:ns) = maybe_add (maybe_add_list acc ns) n
 225
 226     --------------
 227     lexical_lt (n1,_) (n2,_) = nameOrigName n1 < nameOrigName n2
 228
 229     --------------
 230     upp_pair (n, ef)
 231       = uppBeside (ppr_name n) (upp_export ef)
 232       where
 233         upp_export ExportAll = uppPStr SLIT("(..)")
 234         upp_export ExportAbs = uppNil
 235 \end{code}
 236
 237 \begin{code}
 238 ifaceFixities Nothing{-no iface handle-} _ = return ()
 239
 240 ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _)
 241   = let
 242         local_fixities = filter from_here fixities
 243     in
 244     if null local_fixities then
 245         return ()
 246     else
 247         hPutStr if_hdl "\n__fixities__\n" >>
 248         hPutStr if_hdl (uppShow 0 (uppAboves (map uppSemid local_fixities)))
 249   where
 250     from_here (InfixL v _) = isLocallyDefined v
 251     from_here (InfixR v _) = isLocallyDefined v
 252     from_here (InfixN v _) = isLocallyDefined v
 253 \end{code}
 254
 255 \begin{code}
 256 ifaceDecls Nothing{-no iface handle-} _ = return ()
 257
 258 ifaceDecls (Just if_hdl) (vals, tycons, classes, _)
 259   = let
 260         togo_classes = [ c | c <- classes, isLocallyDefined c ]
 261         togo_tycons  = [ t | t <- tycons,  isLocallyDefined t ]
 262         togo_vals    = [ v | v <- vals,    isLocallyDefined v ]
 263
 264         sorted_classes   = sortLt ltLexical togo_classes
 265         sorted_tycons    = sortLt ltLexical togo_tycons
 266         sorted_vals      = sortLt ltLexical togo_vals
 267     in
 268     if (null sorted_classes && null sorted_tycons && null sorted_vals) then
 269         --  You could have a module with just instances in it
 270         return ()
 271     else
 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]]))
 277 \end{code}
 278
 279 \begin{code}
 280 ifaceInstances Nothing{-no iface handle-} _ = return ()
 281
 282 ifaceInstances (Just if_hdl) (_, _, _, insts)
 283   = let
 284         togo_insts      = filter is_togo_inst (bagToList insts)
 285
 286         sorted_insts    = sortLt lt_inst togo_insts
 287     in
 288     if null togo_insts then
 289         return ()
 290     else
 291         hPutStr if_hdl "\n__instances__\n" >>
 292         hPutStr if_hdl (uppShow 0 (uppAboves (map pp_inst sorted_insts)))
 293   where
 294     is_togo_inst (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
 295       = from_here -- && ...
 296
 297     -------
 298     lt_inst (InstInfo clas1 _ ty1 _ _ _ _ _ _ _ _ _)
 299             (InstInfo clas2 _ ty2 _ _ _ _ _ _ _ _ _)
 300       = let
 301             tycon1 = fst (getAppTyCon ty1)
 302             tycon2 = fst (getAppTyCon ty2)
 303         in
 304         case (origName clas1 `cmp` origName clas2) of
 305           LT_ -> True
 306           GT_ -> False
 307           EQ_ -> origName tycon1 < origName tycon2
 308
 309     -------
 310     pp_inst (InstInfo clas tvs ty theta _ _ _ _ _ _ _ _)
 311       = let
 312             forall_ty     = mkSigmaTy tvs theta (mkDictTy clas ty)
 313             renumbered_ty = initNmbr (nmbrType forall_ty)
 314         in
 315         uppBesides [uppPStr SLIT("instance "), ppr_ty renumbered_ty, uppSemi]
 316 \end{code}
 317
 318 %************************************************************************
 319 %*                                                                      *
 320 \subsection{Printing tycons, classes, ...}
 321 %*                                                                      *
 322 %************************************************************************
 323
 324 \begin{code}
 325 ppr_class :: Class -> Unpretty
 326
 327 ppr_class c
 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 ->
 331
 332         uppCat [uppPStr SLIT("class"), ppr_theta tyvar super_classes,
 333                 ppr_name n, ppr_tyvar tyvar,
 334                 if null ops
 335                 then uppSemi
 336                 else uppCat [uppStr "where {", uppCat (map ppr_op ops), uppStr "};"]]
 337     }
 338   where
 339     ppr_theta :: TyVar -> [Class] -> Unpretty
 340
 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),
 346                     uppStr ") =>"]
 347
 348     ppr_assert tv (Class _ n _ _ _ _ _ _ _ _) = uppCat [ppr_name n, ppr_tyvar tv]
 349
 350     ppr_op (ClassOp o _ ty) = pp_sig (Unqual o) ty
 351 \end{code}
 352
 353 \begin{code}
 354 ppr_val v ty -- renumber the type first!
 355   = --pprTrace "ppr_val:" (ppr PprDebug v) $
 356     pp_sig v (initNmbr (nmbrType ty))
 357
 358 pp_sig op ty
 359   = uppBesides [ppr_name op, uppPStr SLIT(" :: "), ppr_ty ty, uppSemi]
 360 \end{code}
 361
 362 \begin{code}
 363 ppr_tycon tycon
 364   = --pprTrace "ppr_tycon:" (ppr PprDebug tycon) $
 365     ppr_tc (initNmbr (nmbrTyCon tycon))
 366
 367 ------------------------
 368 ppr_tc (PrimTyCon _ n _)
 369   = uppCat [ uppStr "{- data", ppr_name n, uppStr " *built-in* -}" ]
 370
 371 ppr_tc FunTyCon
 372   = uppCat [ uppStr "{- data", ppr_name FunTyCon, uppStr " *built-in* -}" ]
 373
 374 ppr_tc (TupleTyCon _ n _)
 375   = uppCat [ uppStr "{- ", ppr_name n, uppStr "-}" ]
 376
 377 ppr_tc (SynTyCon _ n _ _ tvs expand)
 378   = let
 379         pp_tyvars   = map ppr_tyvar tvs
 380     in
 381     uppBesides [uppPStr SLIT("type "), ppr_name n, uppSP, uppIntersperse uppSP pp_tyvars,
 382            uppPStr SLIT(" = "), ppr_ty expand, uppSemi]
 383
 384 ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new)
 385   = uppCat [pp_data_or_new,
 386            ppr_context ctxt,
 387            ppr_name n,
 388            uppIntersperse uppSP (map ppr_tyvar tvs),
 389            pp_unabstract_condecls,
 390            uppSemi]
 391            -- NB: we do not print deriving info in interfaces
 392   where
 393     pp_data_or_new = case data_or_new of
 394                       DataType -> uppPStr SLIT("data")
 395                       NewType  -> uppPStr SLIT("newtype")
 396
 397     ppr_context []      = uppNil
 398     ppr_context [(c,t)] = uppCat [ppr_name c, ppr_ty t, uppPStr SLIT("=>")]
 399     ppr_context cs
 400       = uppBesides[uppLparen,
 401                    uppInterleave uppComma [uppCat [ppr_name c, ppr_ty t] | (c,t) <- cs],
 402                    uppRparen, uppPStr SLIT(" =>")]
 403
 404     yes_we_print_condecls
 405       = case (getExportFlag n) of
 406           ExportAbs -> False
 407           other     -> True
 408
 409     pp_unabstract_condecls
 410       = if yes_we_print_condecls
 411         then uppCat [uppEquals, pp_condecls]
 412         else uppNil
 413
 414     pp_condecls
 415       = let
 416             (c:cs) = cons
 417         in
 418         uppCat ((ppr_con c) : (map ppr_next_con cs))
 419
 420     ppr_next_con con = uppCat [uppChar '|', ppr_con con]
 421
 422     ppr_con con
 423       = let
 424             (_, _, con_arg_tys, _) = dataConSig con
 425             labels       = dataConFieldLabels con -- none if not a record
 426             strict_marks = dataConStrictMarks con
 427         in
 428         uppCat [ppr_unq_name con, ppr_fields labels strict_marks con_arg_tys]
 429
 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)
 433         else
 434             uppCat [ uppChar '{',
 435             uppInterleave uppComma (zipWith3Equal "ppr_field" ppr_field labels strict_marks con_arg_tys),
 436             uppChar '}' ]
 437
 438     ppr_bang_ty b t
 439       = uppBeside (case b of { MarkedStrict -> uppChar '!'; _ -> uppNil })
 440                   (prettyToUn (pprParendType PprInterface t))
 441
 442     ppr_field l b t
 443       = uppBesides [ppr_unq_name l, uppPStr SLIT(" :: "),
 444                    case b of { MarkedStrict -> uppChar '!'; _ -> uppNil },
 445                    ppr_ty t]
 446 \end{code}