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