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 ( mkInterface ) where
  10
  11 import PrelInfo         ( mkLiftTy, pRELUDE_CORE, pRELUDE_BUILTIN )
  12 import HsSyn            ( FixityDecl(..), RenamedFixityDecl(..), MonoBinds,
  13                           RenamedMonoBinds(..), Name, RenamedPat(..), Sig
  14                         )
  15 import Type
  16 import Bag
  17 import FiniteMap
  18 import Id
  19 import IdInfo           -- plenty from here
  20 import Maybes           ( catMaybes, Maybe(..) )
  21 import Outputable
  22 import Pretty
  23 import StgSyn
  24 import TcInstDcls       ( InstInfo(..) )
  25 import Util
  26 \end{code}
  27
  28 %************************************************************************
  29 %*                                                                      *
  30 \subsection[main-MkIface]{Main routine for making interfaces}
  31 %*                                                                      *
  32 %************************************************************************
  33
  34 Misc points:
  35 \begin{enumerate}
  36 \item
  37 We get the general what-to-export information from the ``environments''
  38 produced by the typechecker (the \tr{[RenamedFixityDecl]} through
  39 \tr{Bag InstInfo} arguments).
  40
  41 \item
  42 {\em However:} Whereas (for example) an \tr{InstInfo} will have
  43 \tr{Ids} in it that identify the constant methods for that instance,
  44 those particular \tr{Ids} {\em do not have} the best @IdInfos@!!!
  45 Those @IdInfos@ were figured out long after the \tr{InstInfo} was
  46 created.
  47
  48 That's why we actually look at the final \tr{StgBindings} that go
  49 into the code-generator: they have the best @IdInfos@ on them.
  50 Whenever, we are about to print info about an @Id@, we look in the
  51 Ids-from-STG-bindings list to see if we have an ``equivalent'' @Id@
  52 with presumably-better @IdInfo@.
  53
  54 \item
  55 We play this same game whether for values, classes (for their
  56 method-selectors and default-methods), or instances (for their
  57 @DictFunIds@ or constant-methods).
  58
  59 Of course, for imported things, what we got from the typechecker is
  60 all we're gonna get.
  61
  62 \item
  63 We {\em sort} things in the interface into some ``canonical'' order;
  64 otherwise, with heavily-recursive modules, you can have (unchanged)
  65 information ``move around'' in the interface file---deeply unfriendly
  66 to \tr{make}.
  67 \end{enumerate}
  68
  69 \begin{code}
  70 mkInterface :: FAST_STRING
  71             -> (FAST_STRING -> Bool,  -- is something in export list, explicitly?
  72                 FAST_STRING -> Bool)  -- is a module among the "dotdot" exported modules?
  73             -> IdEnv UnfoldingDetails
  74             -> FiniteMap TyCon [(Bool, [Maybe Type])]
  75             -> ([RenamedFixityDecl],  -- interface info from the typecheck
  76                 [Id],
  77                 CE,
  78                 TCE,
  79                 Bag InstInfo)
  80             -> [StgBinding]
  81             -> Pretty
  82
  83 mkInterface modname export_list_fns inline_env tycon_specs
  84             (fixity_decls, global_ids, ce, tce, inst_infos)
  85             stg_binds
  86   = let
  87         -- first, gather up the things we want to export:
  88
  89         exported_tycons  = [ tc | tc <- rngTCE tce,
  90                            isExported tc,
  91                            is_exportable_tycon_or_class export_list_fns tc ]
  92         exported_classes = [  c |  c <- rngCE  ce,
  93                            isExported  c,
  94                            is_exportable_tycon_or_class export_list_fns  c ]
  95         exported_inst_infos = [ i | i <- bagToList inst_infos,
  96                            is_exported_inst_info export_list_fns i ]
  97         exported_vals
  98           = [ v | v <- global_ids,
  99               isExported v && not (isDataCon v) && not (isClassOpId v) ]
 100
 101         -- We also have to worry about TyCons/Classes that are
 102         -- *mentioned* in exported things (e.g., values' types or
 103         -- instances), so that we can be sure to do an import decl for
 104         -- them, for original-naming purposes:
 105
 106         (mentioned_tycons, mentioned_classes)
 107           = foldr ( \ (tcs1, cls1) (tcs2, cls2)
 108                       -> (tcs1 `unionBags` tcs2, cls1 `unionBags` cls2) )
 109                   (emptyBag, emptyBag)
 110                   (map getMentionedTyConsAndClassesFromClass exported_classes  ++
 111                    map getMentionedTyConsAndClassesFromTyCon exported_tycons   ++
 112                    map getMentionedTyConsAndClassesFromId    exported_vals     ++
 113                    map getMentionedTyConsAndClassesFromInstInfo exported_inst_infos)
 114
 115         mentionable_classes
 116           = filter is_mentionable (bagToList mentioned_classes)
 117         mentionable_tycons
 118           = [ tc | tc <- bagToList mentioned_tycons,
 119                    is_mentionable tc,
 120                    not (isPrimTyCon tc) ]
 121
 122         nondup_mentioned_tycons  = fst (removeDups cmp mentionable_tycons)
 123         nondup_mentioned_classes = fst (removeDups cmp mentionable_classes)
 124
 125         -- Next: as discussed in the notes, we want the top-level
 126         -- Ids straight from the final STG code, so we can use
 127         -- their IdInfos to print pragmas; we slurp them out here,
 128         -- then pass them to the printing functions, which may
 129         -- use them.
 130
 131         better_ids = collectExportedStgBinders stg_binds
 132
 133         -- Make a lookup function for convenient access:
 134
 135         better_id_fn i
 136           = if not (isLocallyDefined i)
 137             then i  -- can't be among our "better_ids"
 138             else
 139                let
 140                    eq_fn = if isTopLevId i -- can't trust uniqs
 141                            then (\ x y -> getOrigName x == getOrigName y)
 142                            else eqId
 143                in
 144                case [ x | x <- better_ids, x `eq_fn` i ] of
 145                  []  -> pprPanic "better_id_fn:" (ppr PprShowAll i)
 146                         i
 147                  [x] -> x
 148                  _   -> panic "better_id_fn"
 149
 150         -- Finally, we sort everything lexically, so that we always
 151         -- get the same interface from the same information:
 152
 153         sorted_mentioned_tycons  = sortLt ltLexical nondup_mentioned_tycons
 154         sorted_mentioned_classes = sortLt ltLexical nondup_mentioned_classes
 155
 156         sorted_tycons     = sortLt ltLexical exported_tycons
 157         sorted_classes    = sortLt ltLexical exported_classes
 158         sorted_vals       = sortLt ltLexical exported_vals
 159         sorted_inst_infos = sortLt lt_lexical_inst_info exported_inst_infos
 160     in
 161     if (any_purely_local sorted_tycons sorted_classes sorted_vals) then
 162         -- this will be less of a HACK when we teach
 163         -- mkInterface to do I/O (WDP 94/10)
 164         error "Can't produce interface file because of errors!\n"
 165     else
 166     ppAboves
 167        [ppPStr SLIT("{-# GHC_PRAGMA INTERFACE VERSION 7 #-}"),
 168         ppCat [ppPStr SLIT("interface"), ppPStr modname, ppPStr SLIT("where")],
 169
 170         do_import_decls modname
 171                 sorted_vals sorted_mentioned_classes sorted_mentioned_tycons,
 172                 -- Mustn't give the data constructors to do_import_decls,
 173                 -- because they aren't explicitly imported; their tycon is.
 174
 175         ppAboves (map do_fixity                                 fixity_decls),
 176         ppAboves (map (pprIfaceClass better_id_fn inline_env)   sorted_classes),
 177         ppAboves (map (do_tycon      tycon_specs)               sorted_tycons),
 178         ppAboves (map (do_value      better_id_fn inline_env)   sorted_vals),
 179         ppAboves (map (do_instance   better_id_fn inline_env)   sorted_inst_infos),
 180
 181         ppChar '\n'
 182        ]
 183   where
 184     any_purely_local tycons classes vals
 185       =  any bad_tc tycons || any bad_cl classes || any bad_id vals
 186       where
 187         bad_cl cl
 188           = case (maybePurelyLocalClass cl) of
 189               Nothing -> False
 190               Just xs -> naughty_trace cl xs
 191
 192         bad_id id
 193           = case (maybePurelyLocalType (idType id)) of
 194               Nothing -> False
 195               Just xs -> naughty_trace id xs
 196
 197         bad_tc tc
 198           = case (maybePurelyLocalTyCon tc) of
 199               Nothing -> False
 200               Just xs -> if exported_abs then False else naughty_trace tc xs
 201           where
 202             exported_abs = case (getExportFlag tc) of { ExportAbs -> True; _ -> False }
 203
 204         naughty_trace x things
 205           = pprTrace "Can't export -- `"
 206                 (ppBesides [ppr PprForUser x, ppStr "' mentions purely local things: ",
 207                         ppInterleave pp'SP things])
 208                 True
 209 \end{code}
 210
 211 %************************************************************************
 212 %*                                                                      *
 213 \subsection[imports-MkIface]{Generating `import' declarations in an interface}
 214 %*                                                                      *
 215 %************************************************************************
 216
 217 We gather up lots of (module, name) pairs for which we might print an
 218 import declaration.  We sort them, for the usual canonicalisation
 219 reasons.  NB: We {\em assume} the lists passed in don't have duplicates in
 220 them!  expect).
 221
 222 All rather horribly turgid (WDP).
 223
 224 \begin{code}
 225 do_import_decls
 226         :: FAST_STRING
 227         -> [Id] -> [Class] -> [TyCon]
 228         -> Pretty
 229
 230 do_import_decls mod_name vals classes tycons
 231   = let
 232         -- Conjure up (module, name) pairs for all
 233         -- the potentially import-decls things:
 234
 235         vals_names, classes_names, tycons_names :: [(FAST_STRING, FAST_STRING, [Maybe FAST_STRING])]
 236         vals_names      = map get_val_pair   vals
 237         classes_names   = map get_class_pair classes
 238         tycons_names    = map get_tycon_pair tycons
 239
 240         -- sort the (module, name) pairs and chop
 241         -- them into per-module groups:
 242
 243         ie_list = sortLt lt (tycons_names ++ classes_names ++ vals_names)
 244
 245         per_module_groups = runs same_module ie_list
 246     in
 247     ppAboves (map print_a_decl per_module_groups)
 248   where
 249     lt, same_module :: (FAST_STRING, FAST_STRING)
 250                     -> (FAST_STRING, FAST_STRING) -> Bool
 251
 252     lt (m1, ie1, ie2)
 253       = case (_CMP_STRING_ m1 m2) of { LT_ -> True; EQ_ -> ie1 < ie2; GT__ -> False }
 254
 255     same_module (m1, _, _) (m2, _, _) = m1 == m2
 256
 257     compiling_the_prelude = opt_CompilingPrelude
 258
 259     print_a_decl :: [(FAST_STRING, FAST_STRING, [Maybe FAST_STRING])] -> Pretty
 260     {-
 261         Obviously, if the module in question is this one,
 262         don't print an import declaration.
 263
 264         If it's a Prelude* module, we don't print the TyCons/
 265         Classes, because the compiler supposedly knows about
 266         them already (and they are PreludeCore things anyway).
 267
 268         But if we are compiling a Prelude module, then we
 269         try to do it as "normally" as possible.
 270     -}
 271     print_a_decl (ielist@((m,_,_) : _))
 272       |  m == mod_name
 273       || (not compiling_the_prelude &&
 274           (m == pRELUDE_CORE || m == pRELUDE_BUILTIN))
 275       = ppNil
 276
 277       | otherwise
 278       = ppBesides [ppPStr SLIT("import "), ppPStr m, ppLparen,
 279                    ppIntersperse pp'SP{-'-} (map pp_str [n | (_,n,_) <- ielist]),
 280                    ppRparen
 281                   ]
 282       where
 283         isnt_tycon_ish :: FAST_STRING -> Bool
 284         isnt_tycon_ish str = not (isConop str)
 285
 286         grab_non_Nothings :: [[Maybe FAST_STRING]] -> [FAST_STRING]
 287
 288         grab_non_Nothings rns = catMaybes (concat rns)
 289
 290         pp_str :: FAST_STRING -> Pretty
 291         pp_str pstr
 292           = if isAvarop pstr then ppStr ("("++str++")") else ppPStr pstr
 293           where
 294             str = _UNPK_ pstr
 295 \end{code}
 296
 297 \begin{code}
 298 get_val_pair   :: Id    -> (FAST_STRING, FAST_STRING)
 299 get_class_pair :: Class -> (FAST_STRING, FAST_STRING)
 300 get_tycon_pair :: TyCon -> (FAST_STRING, FAST_STRING)
 301
 302 get_val_pair id
 303   = generic_pair id
 304
 305 get_class_pair clas
 306   = case (generic_pair clas) of { (orig_mod, orig_nm) ->
 307     let
 308         nm_to_print = case (getExportFlag clas) of
 309                         ExportAll   -> orig_nm _APPEND_ SLIT("(..)") -- nothing like a good HACK!
 310                         ExportAbs   -> orig_nm
 311                         NotExported -> orig_nm
 312     in
 313     (orig_mod, nm_to_print) }
 314
 315 get_tycon_pair tycon
 316   = case (generic_pair tycon) of { (orig_mod, orig_nm) ->
 317     let
 318         nm_to_print = case (getExportFlag tycon) of
 319                         ExportAll   -> orig_nm _APPEND_ SLIT("(..)") -- nothing like a good HACK!
 320                         ExportAbs   -> orig_nm
 321                         NotExported -> orig_nm
 322
 323         cons        = tyConDataCons tycon
 324     in
 325     (orig_mod, nm_to_print) }
 326
 327 generic_pair thing
 328   = case (getOrigName       thing) of { (orig_mod, orig_nm) ->
 329     case (getOccurrenceName thing) of { occur_name ->
 330     (orig_mod, orig_nm) }}
 331 \end{code}
 332
 333 %************************************************************************
 334 %*                                                                      *
 335 \subsection[fixities-MkIface]{Generating fixity declarations in an interface}
 336 %*                                                                      *
 337 %************************************************************************
 338
 339
 340 \begin{code}
 341 do_fixity :: -> RenamedFixityDecl -> Pretty
 342
 343 do_fixity fixity_decl
 344   = case (getExportFlag (get_name fixity_decl)) of
 345       ExportAll -> ppr PprInterface fixity_decl
 346       _         -> ppNil
 347   where
 348      get_name (InfixL n _) = n
 349      get_name (InfixR n _) = n
 350      get_name (InfixN n _) = n
 351 \end{code}
 352
 353 %************************************************************************
 354 %*                                                                      *
 355 \subsection[tycons-MkIface]{Generating tycon declarations in an interface}
 356 %*                                                                      *
 357 %************************************************************************
 358
 359 \begin{code}
 360 do_tycon :: FiniteMap TyCon [(Bool, [Maybe Type])] -> TyCon -> Pretty
 361
 362 do_tycon tycon_specs_map tycon
 363   = pprTyCon PprInterface tycon tycon_specs
 364   where
 365     tycon_specs = map snd (lookupWithDefaultFM tycon_specs_map [] tycon)
 366 \end{code}
 367
 368 %************************************************************************
 369 %*                                                                      *
 370 \subsection[values-MkIface]{Generating a value's signature in an interface}
 371 %*                                                                      *
 372 %************************************************************************
 373
 374 \begin{code}
 375 do_value :: (Id -> Id)
 376          -> IdEnv UnfoldingDetails
 377          -> Id
 378          -> Pretty
 379
 380 do_value better_id_fn inline_env val
 381   = let
 382         sty         = PprInterface
 383         better_val  = better_id_fn val
 384         name_str    = getOccurrenceName better_val -- NB: not orig name!
 385
 386         id_info     = getIdInfo better_val
 387
 388         val_ty      = let
 389                          orig_ty  = idType val
 390                          final_ty = idType better_val
 391                       in
 392 --                    ASSERT (orig_ty == final_ty || mkLiftTy orig_ty == final_ty)
 393                       ASSERT (if (orig_ty == final_ty || mkLiftTy orig_ty == final_ty) then True else pprTrace "do_value:" (ppCat [ppr PprDebug val, ppr PprDebug better_val]) False)
 394                       orig_ty
 395
 396         -- Note: We export the type of the original val
 397         -- The type of an unboxed val will have been *lifted* by the desugarer
 398         -- In this case we export an unlifted type, but id_info which assumes
 399         --   a lifted Id i.e. extracted from better_val (above)
 400         -- The importing module must lift the Id before using the imported id_info
 401
 402         pp_id_info
 403           = if opt_OmitInterfacePragmas
 404             || boringIdInfo id_info
 405             then ppNil
 406             else ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"),
 407                         ppIdInfo sty better_val True{-yes specs-}
 408                             better_id_fn inline_env id_info,
 409                         ppPStr SLIT("#-}")]
 410     in
 411     ppAbove (ppCat [ppr_non_op name_str,
 412                     ppPStr SLIT("::"), pprGenType sty val_ty])
 413             pp_id_info
 414
 415 -- sadly duplicates Outputable.pprNonOp (ToDo)
 416
 417 ppr_non_op str
 418   = if isAvarop str -- NOT NEEDED: || isAconop
 419     then ppBesides [ppLparen, ppPStr str, ppRparen]
 420     else ppPStr str
 421 \end{code}
 422
 423 %************************************************************************
 424 %*                                                                      *
 425 \subsection[instances-MkIface]{Generating instance declarations in an interface}
 426 %*                                                                      *
 427 %************************************************************************
 428
 429 The types of ``dictionary functions'' (dfuns) have just the required
 430 info for instance declarations in interfaces.  However, the dfuns that
 431 GHC really uses have {\em extra} dictionaries passed to them (for
 432 efficiency).  When we print interfaces, we want to omit that
 433 dictionary information.  (It can be reconsituted on the other end,
 434 from instance and class decls).
 435
 436 \begin{code}
 437 do_instance :: (Id -> Id)
 438             -> IdEnv UnfoldingDetails
 439             -> InstInfo
 440             -> Pretty
 441
 442 do_instance better_id_fn inline_env
 443     (InstInfo clas tv_tmpls ty inst_decl_theta dfun_theta dfun_id constm_ids _ from_here modname _ _)
 444   = let
 445         sty = PprInterface
 446
 447         better_dfun      = better_id_fn dfun_id
 448         better_dfun_info = getIdInfo better_dfun
 449         better_constms   = map better_id_fn constm_ids
 450
 451         class_op_strs = map getClassOpString (getClassOps clas)
 452
 453         pragma_begin
 454           = ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"), pp_modname, ppPStr SLIT("{-dfun-}"),
 455                    ppIdInfo sty better_dfun False{-NO specs-}
 456                     better_id_fn inline_env better_dfun_info]
 457
 458         pragma_end = ppPStr SLIT("#-}")
 459
 460         pp_modname = if _NULL_ modname
 461                      then ppNil
 462                      else ppCat [ppStr "_M_", ppPStr modname]
 463
 464         name_pragma_pairs
 465           = pp_the_list [ ppCat [ppChar '\t', ppr_non_op op, ppEquals,
 466                                  ppChar '{' ,
 467                                  ppIdInfo sty constm True{-YES, specs-}
 468                                   better_id_fn inline_env
 469                                   (getIdInfo constm),
 470                                  ppChar '}' ]
 471                         | (op, constm) <- class_op_strs `zip` better_constms ]
 472
 473 #ifdef DEBUG
 474         pp_the_list [] = panic "MkIface: no class_ops or better_constms?"
 475 #endif
 476         pp_the_list [p]    = p
 477         pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
 478
 479         real_stuff
 480           = ppCat [ppPStr SLIT("instance"),
 481                    ppr sty (mkSigmaTy tv_tmpls inst_decl_theta (mkDictTy clas ty))]
 482     in
 483     if opt_OmitInterfacePragmas
 484     || boringIdInfo better_dfun_info
 485     then real_stuff
 486     else ppAbove real_stuff
 487           ({-ppNest 8 -} -- ppNest does nothing
 488              if null better_constms
 489              then ppCat [pragma_begin, pragma_end]
 490              else ppAbove pragma_begin (ppCat [name_pragma_pairs, pragma_end])
 491           )
 492 \end{code}
 493
 494 %************************************************************************
 495 %*                                                                      *
 496 \subsection[utils-InstInfos]{Utility functions for @InstInfos@}
 497 %*                                                                      *
 498 %************************************************************************
 499
 500 ToDo: perhaps move.
 501
 502 Classes/TyCons are ``known,'' more-or-less.  Prelude TyCons are
 503 ``completely'' known---they don't need to be mentioned in interfaces.
 504 Classes usually don't need to be mentioned in interfaces, but if we're
 505 compiling the prelude, then we treat them without special favours.
 506 \begin{code}
 507 is_exportable_tycon_or_class export_list_fns tc
 508   = if not (fromPreludeCore tc) then
 509         True
 510     else
 511         in_export_list_or_among_dotdot_modules
 512             opt_CompilingPrelude -- ignore M.. stuff if compiling prelude
 513             export_list_fns tc
 514
 515 in_export_list_or_among_dotdot_modules ignore_Mdotdots (in_export_list, among_dotdot_modules) tc
 516   = if in_export_list (getOccurrenceName tc) then
 517         True
 518     else
 519 --      pprTrace "in_export:" (ppAbove (ppr PprDebug ignore_Mdotdots) (ppPStr (getOccurrenceName tc))) (
 520     if ignore_Mdotdots then
 521         False
 522     else
 523         any among_dotdot_modules (getInformingModules tc)
 524 --  )
 525
 526 is_mentionable tc
 527   = not (from_PreludeCore_or_Builtin tc) || opt_CompilingPrelude
 528   where
 529     from_PreludeCore_or_Builtin thing
 530       = let
 531             mod_name = fst (getOrigName thing)
 532         in
 533         mod_name == pRELUDE_CORE || mod_name == pRELUDE_BUILTIN
 534
 535 is_exported_inst_info export_list_fns
 536         (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
 537   = let
 538         seems_exported = instanceIsExported clas ty from_here
 539         (tycon, _, _) = getAppTyCon ty
 540     in
 541     if (opt_OmitReexportedInstances && not from_here) then
 542         False -- Flag says to violate Haskell rules, blatantly
 543
 544     else if not opt_CompilingPrelude
 545          || not (isFunTyCon tycon || fromPreludeCore tycon)
 546          || not (fromPreludeCore clas) then
 547         seems_exported -- take what we got
 548
 549     else -- compiling Prelude & tycon/class are Prelude things...
 550         from_here
 551         || in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns clas
 552         || in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns tycon
 553 \end{code}
 554
 555 \begin{code}
 556 lt_lexical_inst_info (InstInfo _ _ _ _ _ dfun1 _ _ _ _ _ _) (InstInfo _ _ _ _ _ dfun2 _ _ _ _ _ _)
 557   = ltLexical dfun1 dfun2
 558 \end{code}
 559
 560 \begin{code}
 561 getMentionedTyConsAndClassesFromInstInfo (InstInfo clas _ ty _ dfun_theta _ _ _ _ _ _ _)
 562   = case (getMentionedTyConsAndClassesFromType ty) of { (ts, cs) ->
 563     case [ c | (c, _) <- dfun_theta ]                 of { theta_classes ->
 564     (ts, (cs `unionBags` listToBag theta_classes) `snocBag` clas)
 565     }}
 566 \end{code}