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