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 --  trace ("mkIface:Ids:"++(ppShow 80 (ppr PprDebug global_ids))) (
 167     ppAboves
 168        [ppPStr SLIT("{-# GHC_PRAGMA INTERFACE VERSION 7 #-}"),
 169         ppCat [ppPStr SLIT("interface"), ppPStr modname, ppPStr SLIT("where")],
 170
 171         do_import_decls modname
 172                 sorted_vals sorted_mentioned_classes sorted_mentioned_tycons,
 173                 -- Mustn't give the data constructors to do_import_decls,
 174                 -- because they aren't explicitly imported; their tycon is.
 175
 176         ppAboves (map do_fixity                                 fixity_decls),
 177         ppAboves (map (pprIfaceClass better_id_fn inline_env)   sorted_classes),
 178         ppAboves (map (do_tycon      tycon_specs)               sorted_tycons),
 179         ppAboves (map (do_value      better_id_fn inline_env)   sorted_vals),
 180         ppAboves (map (do_instance   better_id_fn inline_env)   sorted_inst_infos),
 181
 182         ppChar '\n'
 183        ]
 184 --  )
 185   where
 186     any_purely_local tycons classes vals
 187       =  any bad_tc tycons || any bad_cl classes || any bad_id vals
 188       where
 189         bad_cl cl
 190           = case (maybePurelyLocalClass cl) of
 191               Nothing -> False
 192               Just xs -> naughty_trace cl xs
 193
 194         bad_id id
 195           = case (maybePurelyLocalType (idType id)) of
 196               Nothing -> False
 197               Just xs -> naughty_trace id xs
 198
 199         bad_tc tc
 200           = case (maybePurelyLocalTyCon tc) of
 201               Nothing -> False
 202               Just xs -> if exported_abs then False else naughty_trace tc xs
 203           where
 204             exported_abs = case (getExportFlag tc) of { ExportAbs -> True; _ -> False }
 205
 206         naughty_trace x things
 207           = pprTrace "Can't export -- `"
 208                 (ppBesides [ppr PprForUser x, ppStr "' mentions purely local things: ",
 209                         ppInterleave pp'SP things])
 210                 True
 211 \end{code}
 212
 213 %************************************************************************
 214 %*                                                                      *
 215 \subsection[imports-MkIface]{Generating `import' declarations in an interface}
 216 %*                                                                      *
 217 %************************************************************************
 218
 219 We gather up lots of (module, name) pairs for which we might print an
 220 import declaration.  We sort them, for the usual canonicalisation
 221 reasons.  NB: We {\em assume} the lists passed in don't have duplicates in
 222 them!  expect).
 223
 224 All rather horribly turgid (WDP).
 225
 226 \begin{code}
 227 do_import_decls
 228         :: FAST_STRING
 229         -> [Id] -> [Class] -> [TyCon]
 230         -> Pretty
 231
 232 do_import_decls mod_name vals classes tycons
 233   = let
 234         -- Conjure up (module, name) pairs for all
 235         -- the potentially import-decls things:
 236
 237         vals_names, classes_names, tycons_names :: [(FAST_STRING, FAST_STRING, [Maybe FAST_STRING])]
 238         vals_names      = map get_val_pair   vals
 239         classes_names   = map get_class_pair classes
 240         tycons_names    = map get_tycon_pair tycons
 241
 242         -- sort the (module, name) pairs and chop
 243         -- them into per-module groups:
 244
 245         ie_list = sortLt lt (tycons_names ++ classes_names ++ vals_names)
 246
 247         per_module_groups = runs same_module ie_list
 248     in
 249     ppAboves (map print_a_decl per_module_groups)
 250   where
 251     lt, same_module :: (FAST_STRING, FAST_STRING)
 252                     -> (FAST_STRING, FAST_STRING) -> Bool
 253
 254     lt (m1, ie1, ie2)
 255       = case (_CMP_STRING_ m1 m2) of { LT_ -> True; EQ_ -> ie1 < ie2; GT__ -> False }
 256
 257     same_module (m1, _, _) (m2, _, _) = m1 == m2
 258
 259     compiling_the_prelude = opt_CompilingPrelude
 260
 261     print_a_decl :: [(FAST_STRING, FAST_STRING, [Maybe FAST_STRING])] -> Pretty
 262     {-
 263         Obviously, if the module in question is this one,
 264         don't print an import declaration.
 265
 266         If it's a Prelude* module, we don't print the TyCons/
 267         Classes, because the compiler supposedly knows about
 268         them already (and they are PreludeCore things anyway).
 269
 270         But if we are compiling a Prelude module, then we
 271         try to do it as "normally" as possible.
 272     -}
 273     print_a_decl (ielist@((m,_,_) : _))
 274       |  m == mod_name
 275       || (not compiling_the_prelude &&
 276           (m == pRELUDE_CORE || m == pRELUDE_BUILTIN))
 277       = ppNil
 278
 279       | otherwise
 280       = ppBesides [ppPStr SLIT("import "), ppPStr m, ppLparen,
 281                    ppIntersperse pp'SP{-'-} (map pp_str [n | (_,n,_) <- ielist]),
 282                    ppRparen
 283                   ]
 284       where
 285         isnt_tycon_ish :: FAST_STRING -> Bool
 286         isnt_tycon_ish str = not (isConop str)
 287
 288         grab_non_Nothings :: [[Maybe FAST_STRING]] -> [FAST_STRING]
 289
 290         grab_non_Nothings rns = catMaybes (concat rns)
 291
 292         pp_str :: FAST_STRING -> Pretty
 293         pp_str pstr
 294           = if isAvarop pstr then ppStr ("("++str++")") else ppPStr pstr
 295           where
 296             str = _UNPK_ pstr
 297 \end{code}
 298
 299 \begin{code}
 300 get_val_pair   :: Id    -> (FAST_STRING, FAST_STRING)
 301 get_class_pair :: Class -> (FAST_STRING, FAST_STRING)
 302 get_tycon_pair :: TyCon -> (FAST_STRING, FAST_STRING)
 303
 304 get_val_pair id
 305   = generic_pair id
 306
 307 get_class_pair clas
 308   = case (generic_pair clas) of { (orig_mod, orig_nm) ->
 309     let
 310         nm_to_print = case (getExportFlag clas) of
 311                         ExportAll   -> orig_nm _APPEND_ SLIT("(..)") -- nothing like a good HACK!
 312                         ExportAbs   -> orig_nm
 313                         NotExported -> orig_nm
 314     in
 315     (orig_mod, nm_to_print) }
 316
 317 get_tycon_pair tycon
 318   = case (generic_pair tycon) of { (orig_mod, orig_nm) ->
 319     let
 320         nm_to_print = case (getExportFlag tycon) of
 321                         ExportAll   -> orig_nm _APPEND_ SLIT("(..)") -- nothing like a good HACK!
 322                         ExportAbs   -> orig_nm
 323                         NotExported -> orig_nm
 324
 325         cons        = getTyConDataCons tycon
 326     in
 327     (orig_mod, nm_to_print) }
 328
 329 generic_pair thing
 330   = case (getOrigName       thing) of { (orig_mod, orig_nm) ->
 331     case (getOccurrenceName thing) of { occur_name ->
 332     (orig_mod, orig_nm) }}
 333 \end{code}
 334
 335 %************************************************************************
 336 %*                                                                      *
 337 \subsection[fixities-MkIface]{Generating fixity declarations in an interface}
 338 %*                                                                      *
 339 %************************************************************************
 340
 341
 342 \begin{code}
 343 do_fixity :: -> RenamedFixityDecl -> Pretty
 344
 345 do_fixity fixity_decl
 346   = case (getExportFlag (get_name fixity_decl)) of
 347       ExportAll -> ppr PprInterface fixity_decl
 348       _         -> ppNil
 349   where
 350      get_name (InfixL n _) = n
 351      get_name (InfixR n _) = n
 352      get_name (InfixN n _) = n
 353 \end{code}
 354
 355 %************************************************************************
 356 %*                                                                      *
 357 \subsection[tycons-MkIface]{Generating tycon declarations in an interface}
 358 %*                                                                      *
 359 %************************************************************************
 360
 361 \begin{code}
 362 do_tycon :: FiniteMap TyCon [(Bool, [Maybe Type])] -> TyCon -> Pretty
 363
 364 do_tycon tycon_specs_map tycon
 365   = pprTyCon PprInterface tycon tycon_specs
 366   where
 367     tycon_specs = map snd (lookupWithDefaultFM tycon_specs_map [] tycon)
 368 \end{code}
 369
 370 %************************************************************************
 371 %*                                                                      *
 372 \subsection[values-MkIface]{Generating a value's signature in an interface}
 373 %*                                                                      *
 374 %************************************************************************
 375
 376 \begin{code}
 377 do_value :: (Id -> Id)
 378          -> IdEnv UnfoldingDetails
 379          -> Id
 380          -> Pretty
 381
 382 do_value better_id_fn inline_env val
 383   = let
 384         sty         = PprInterface
 385         better_val  = better_id_fn val
 386         name_str    = getOccurrenceName better_val -- NB: not orig name!
 387
 388         id_info     = getIdInfo better_val
 389
 390         val_ty      = let
 391                          orig_ty  = idType val
 392                          final_ty = idType better_val
 393                       in
 394 --                    ASSERT (orig_ty == final_ty || mkLiftTy orig_ty == final_ty)
 395                       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)
 396                       orig_ty
 397
 398         -- Note: We export the type of the original val
 399         -- The type of an unboxed val will have been *lifted* by the desugarer
 400         -- In this case we export an unlifted type, but id_info which assumes
 401         --   a lifted Id i.e. extracted from better_val (above)
 402         -- The importing module must lift the Id before using the imported id_info
 403
 404         pp_id_info
 405           = if opt_OmitInterfacePragmas
 406             || boringIdInfo id_info
 407             then ppNil
 408             else ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"),
 409                         ppIdInfo sty better_val True{-yes specs-}
 410                             better_id_fn inline_env id_info,
 411                         ppPStr SLIT("#-}")]
 412     in
 413     ppAbove (ppCat [ppr_non_op name_str,
 414                     ppPStr SLIT("::"), pprType sty val_ty])
 415             pp_id_info
 416
 417 -- sadly duplicates Outputable.pprNonOp (ToDo)
 418
 419 ppr_non_op str
 420   = if isAvarop str -- NOT NEEDED: || isAconop
 421     then ppBesides [ppLparen, ppPStr str, ppRparen]
 422     else ppPStr str
 423 \end{code}
 424
 425 %************************************************************************
 426 %*                                                                      *
 427 \subsection[instances-MkIface]{Generating instance declarations in an interface}
 428 %*                                                                      *
 429 %************************************************************************
 430
 431 The types of ``dictionary functions'' (dfuns) have just the required
 432 info for instance declarations in interfaces.  However, the dfuns that
 433 GHC really uses have {\em extra} dictionaries passed to them (for
 434 efficiency).  When we print interfaces, we want to omit that
 435 dictionary information.  (It can be reconsituted on the other end,
 436 from instance and class decls).
 437
 438 \begin{code}
 439 do_instance :: (Id -> Id)
 440             -> IdEnv UnfoldingDetails
 441             -> InstInfo
 442             -> Pretty
 443
 444 do_instance better_id_fn inline_env
 445     (InstInfo clas tv_tmpls ty inst_decl_theta dfun_theta dfun_id constm_ids _ from_here modname _ _)
 446   = let
 447         sty = PprInterface
 448
 449         better_dfun      = better_id_fn dfun_id
 450         better_dfun_info = getIdInfo better_dfun
 451         better_constms   = map better_id_fn constm_ids
 452
 453         class_op_strs = map getClassOpString (getClassOps clas)
 454
 455         pragma_begin
 456           = ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"), pp_modname, ppPStr SLIT("{-dfun-}"),
 457                    ppIdInfo sty better_dfun False{-NO specs-}
 458                     better_id_fn inline_env better_dfun_info]
 459
 460         pragma_end = ppPStr SLIT("#-}")
 461
 462         pp_modname = if _NULL_ modname
 463                      then ppNil
 464                      else ppCat [ppStr "_M_", ppPStr modname]
 465
 466         name_pragma_pairs
 467           = pp_the_list [ ppCat [ppChar '\t', ppr_non_op op, ppEquals,
 468                                  ppChar '{' ,
 469                                  ppIdInfo sty constm True{-YES, specs-}
 470                                   better_id_fn inline_env
 471                                   (getIdInfo constm),
 472                                  ppChar '}' ]
 473                         | (op, constm) <- class_op_strs `zip` better_constms ]
 474
 475 #ifdef DEBUG
 476         pp_the_list [] = panic "MkIface: no class_ops or better_constms?"
 477 #endif
 478         pp_the_list [p]    = p
 479         pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
 480
 481         real_stuff
 482           = ppCat [ppPStr SLIT("instance"),
 483                    ppr sty (mkSigmaTy tv_tmpls inst_decl_theta (mkDictTy clas ty))]
 484     in
 485     if opt_OmitInterfacePragmas
 486     || boringIdInfo better_dfun_info
 487     then real_stuff
 488     else ppAbove real_stuff
 489           ({-ppNest 8 -} -- ppNest does nothing
 490              if null better_constms
 491              then ppCat [pragma_begin, pragma_end]
 492              else ppAbove pragma_begin (ppCat [name_pragma_pairs, pragma_end])
 493           )
 494 \end{code}
 495
 496 %************************************************************************
 497 %*                                                                      *
 498 \subsection[utils-InstInfos]{Utility functions for @InstInfos@}
 499 %*                                                                      *
 500 %************************************************************************
 501
 502 ToDo: perhaps move.
 503
 504 Classes/TyCons are ``known,'' more-or-less.  Prelude TyCons are
 505 ``completely'' known---they don't need to be mentioned in interfaces.
 506 Classes usually don't need to be mentioned in interfaces, but if we're
 507 compiling the prelude, then we treat them without special favours.
 508 \begin{code}
 509 is_exportable_tycon_or_class export_list_fns tc
 510   = if not (fromPreludeCore tc) then
 511         True
 512     else
 513         in_export_list_or_among_dotdot_modules
 514             opt_CompilingPrelude -- ignore M.. stuff if compiling prelude
 515             export_list_fns tc
 516
 517 in_export_list_or_among_dotdot_modules ignore_Mdotdots (in_export_list, among_dotdot_modules) tc
 518   = if in_export_list (getOccurrenceName tc) then
 519         True
 520     else
 521 --      pprTrace "in_export:" (ppAbove (ppr PprDebug ignore_Mdotdots) (ppPStr (getOccurrenceName tc))) (
 522     if ignore_Mdotdots then
 523         False
 524     else
 525         any among_dotdot_modules (getInformingModules tc)
 526 --  )
 527
 528 is_mentionable tc
 529   = not (from_PreludeCore_or_Builtin tc) || opt_CompilingPrelude
 530   where
 531     from_PreludeCore_or_Builtin thing
 532       = let
 533             mod_name = fst (getOrigName thing)
 534         in
 535         mod_name == pRELUDE_CORE || mod_name == pRELUDE_BUILTIN
 536
 537 is_exported_inst_info export_list_fns
 538         (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
 539   = let
 540         seems_exported = instanceIsExported clas ty from_here
 541         (tycon, _, _) = getAppTyCon ty
 542     in
 543     if (opt_OmitReexportedInstances && not from_here) then
 544         False -- Flag says to violate Haskell rules, blatantly
 545
 546     else if not opt_CompilingPrelude
 547          || not (isFunTyCon tycon || fromPreludeCore tycon)
 548          || not (fromPreludeCore clas) then
 549         seems_exported -- take what we got
 550
 551     else -- compiling Prelude & tycon/class are Prelude things...
 552         from_here
 553         || in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns clas
 554         || in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns tycon
 555 \end{code}
 556
 557 \begin{code}
 558 lt_lexical_inst_info (InstInfo _ _ _ _ _ dfun1 _ _ _ _ _ _) (InstInfo _ _ _ _ _ dfun2 _ _ _ _ _ _)
 559   = ltLexical dfun1 dfun2
 560 \end{code}
 561
 562 \begin{code}
 563 getMentionedTyConsAndClassesFromInstInfo (InstInfo clas _ ty _ dfun_theta _ _ _ _ _ _ _)
 564   = case (getMentionedTyConsAndClassesFromType ty) of { (ts, cs) ->
 565     case [ c | (c, _) <- dfun_theta ]                 of { theta_classes ->
 566     (ts, (cs `unionBags` listToBag theta_classes) `snocBag` clas)
 567     }}
 568 \end{code}