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_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 -> origName x == origName 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           ({-OLD: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 (isLexCon 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 isLexVarSym 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 (moduleNamePair       thing) of { (orig_mod, orig_nm) ->
 329     case (getOccName 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 (isLocallyDefined name, getExportFlag name) of
 345       (True, ExportAll) -> ppr PprInterface fixity_decl
 346       _                 -> ppNil
 347   where
 348      name = get_name fixity_decl
 349      get_name (InfixL n _) = n
 350      get_name (InfixR n _) = n
 351      get_name (InfixN n _) = n
 352 \end{code}
 353
 354 %************************************************************************
 355 %*                                                                      *
 356 \subsection[tycons-MkIface]{Generating tycon declarations in an interface}
 357 %*                                                                      *
 358 %************************************************************************
 359
 360 \begin{code}
 361 do_tycon :: FiniteMap TyCon [(Bool, [Maybe Type])] -> TyCon -> Pretty
 362
 363 do_tycon tycon_specs_map tycon
 364   = pprTyCon PprInterface tycon tycon_specs
 365   where
 366     tycon_specs = map snd (lookupWithDefaultFM tycon_specs_map [] tycon)
 367 \end{code}
 368
 369 %************************************************************************
 370 %*                                                                      *
 371 \subsection[values-MkIface]{Generating a value's signature in an interface}
 372 %*                                                                      *
 373 %************************************************************************
 374
 375 \begin{code}
 376 do_value :: (Id -> Id)
 377          -> IdEnv UnfoldingDetails
 378          -> Id
 379          -> Pretty
 380
 381 do_value better_id_fn inline_env val
 382   = let
 383         sty         = PprInterface
 384         better_val  = better_id_fn val
 385         name_str    = getOccName better_val -- NB: not orig name!
 386
 387         id_info     = getIdInfo better_val
 388
 389         val_ty      = let
 390                          orig_ty  = idType val
 391                          final_ty = idType better_val
 392                       in
 393 --                    ASSERT (orig_ty == final_ty || mkLiftTy orig_ty == final_ty)
 394                       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)
 395                       orig_ty
 396
 397         -- Note: We export the type of the original val
 398         -- The type of an unboxed val will have been *lifted* by the desugarer
 399         -- In this case we export an unlifted type, but id_info which assumes
 400         --   a lifted Id i.e. extracted from better_val (above)
 401         -- The importing module must lift the Id before using the imported id_info
 402
 403         pp_id_info
 404           = if opt_OmitInterfacePragmas
 405             || boringIdInfo id_info
 406             then ppNil
 407             else ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"),
 408                         ppIdInfo sty better_val True{-yes specs-}
 409                             better_id_fn inline_env id_info,
 410                         ppPStr SLIT("#-}")]
 411     in
 412     ppAbove (ppCat [ppr_non_op name_str,
 413                     ppPStr SLIT("::"), pprGenType sty val_ty])
 414             pp_id_info
 415
 416 -- sadly duplicates Name.pprNonSym (ToDo)
 417
 418 ppr_non_op str
 419   = if isLexVarSym str -- NOT NEEDED: || isAconop
 420     then ppBesides [ppLparen, ppPStr str, ppRparen]
 421     else ppPStr str
 422 \end{code}
 423
 424 %************************************************************************
 425 %*                                                                      *
 426 \subsection[instances-MkIface]{Generating instance declarations in an interface}
 427 %*                                                                      *
 428 %************************************************************************
 429
 430 The types of ``dictionary functions'' (dfuns) have just the required
 431 info for instance declarations in interfaces.  However, the dfuns that
 432 GHC really uses have {\em extra} dictionaries passed to them (for
 433 efficiency).  When we print interfaces, we want to omit that
 434 dictionary information.  (It can be reconsituted on the other end,
 435 from instance and class decls).
 436
 437 \begin{code}
 438 do_instance :: (Id -> Id)
 439             -> IdEnv UnfoldingDetails
 440             -> InstInfo
 441             -> Pretty
 442
 443 do_instance better_id_fn inline_env
 444     (InstInfo clas tv_tmpls ty inst_decl_theta dfun_theta dfun_id constm_ids _ from_here modname _ _)
 445   = let
 446         sty = PprInterface
 447
 448         better_dfun      = better_id_fn dfun_id
 449         better_dfun_info = getIdInfo better_dfun
 450         better_constms   = map better_id_fn constm_ids
 451
 452         class_op_strs = map getClassOpString (getClassOps clas)
 453
 454         pragma_begin
 455           = ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"), pp_modname, ppPStr SLIT("{-dfun-}"),
 456                    ppIdInfo sty better_dfun False{-NO specs-}
 457                     better_id_fn inline_env better_dfun_info]
 458
 459         pragma_end = ppPStr SLIT("#-}")
 460
 461         pp_modname = if _NULL_ modname
 462                      then ppNil
 463                      else ppCat [ppStr "_M_", ppPStr modname]
 464
 465         name_pragma_pairs
 466           = pp_the_list [ ppCat [ppChar '\t', ppr_non_op op, ppEquals,
 467                                  ppChar '{' ,
 468                                  ppIdInfo sty constm True{-YES, specs-}
 469                                   better_id_fn inline_env
 470                                   (getIdInfo constm),
 471                                  ppChar '}' ]
 472                         | (op, constm) <- class_op_strs `zip` better_constms ]
 473
 474 #ifdef DEBUG
 475         pp_the_list [] = panic "MkIface: no class_ops or better_constms?"
 476 #endif
 477         pp_the_list [p]    = p
 478         pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
 479
 480         real_stuff
 481           = ppCat [ppPStr SLIT("instance"),
 482                    ppr sty (mkSigmaTy tv_tmpls inst_decl_theta (mkDictTy clas ty))]
 483     in
 484     if opt_OmitInterfacePragmas
 485     || boringIdInfo better_dfun_info
 486     then real_stuff
 487     else ppAbove real_stuff
 488           ({-ppNest 8 -} -- ppNest does nothing
 489              if null better_constms
 490              then ppCat [pragma_begin, pragma_end]
 491              else ppAbove pragma_begin (ppCat [name_pragma_pairs, pragma_end])
 492           )
 493 \end{code}
 494
 495 %************************************************************************
 496 %*                                                                      *
 497 \subsection[utils-InstInfos]{Utility functions for @InstInfos@}
 498 %*                                                                      *
 499 %************************************************************************
 500
 501 ToDo: perhaps move.
 502
 503 Classes/TyCons are ``known,'' more-or-less.  Prelude TyCons are
 504 ``completely'' known---they don't need to be mentioned in interfaces.
 505 Classes usually don't need to be mentioned in interfaces, but if we're
 506 compiling the prelude, then we treat them without special favours.
 507 \begin{code}
 508 is_exportable_tycon_or_class export_list_fns tc
 509   = if not (fromPreludeCore tc) then
 510         True
 511     else
 512         in_export_list_or_among_dotdot_modules
 513             opt_CompilingPrelude -- ignore M.. stuff if compiling prelude
 514             export_list_fns tc
 515
 516 in_export_list_or_among_dotdot_modules ignore_Mdotdots (in_export_list, among_dotdot_modules) tc
 517   = if in_export_list (getOccName tc) then
 518         True
 519     else
 520 --      pprTrace "in_export:" (ppAbove (ppr PprDebug ignore_Mdotdots) (ppPStr (getOccName  tc))) (
 521     if ignore_Mdotdots then
 522         False
 523     else
 524         any among_dotdot_modules (getInformingModules tc)
 525 --  )
 526
 527 is_mentionable tc
 528   = not (from_PreludeCore_or_Builtin tc) || opt_CompilingPrelude
 529   where
 530     from_PreludeCore_or_Builtin thing
 531       = let
 532             mod_name = fst (moduleNamePair thing)
 533         in
 534         mod_name == pRELUDE_CORE || mod_name == pRELUDE_BUILTIN
 535
 536 is_exported_inst_info export_list_fns
 537         (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
 538   = let
 539         seems_exported = instanceIsExported clas ty from_here
 540         (tycon, _, _) = getAppTyCon ty
 541     in
 542     if (opt_OmitReexportedInstances && not from_here) then
 543         False -- Flag says to violate Haskell rules, blatantly
 544
 545     else if not opt_CompilingPrelude
 546          || not (isFunTyCon tycon || fromPreludeCore tycon)
 547          || not (fromPreludeCore clas) then
 548         seems_exported -- take what we got
 549
 550     else -- compiling Prelude & tycon/class are Prelude things...
 551         from_here
 552         || in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns clas
 553         || in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns tycon
 554 \end{code}
 555
 556 \begin{code}
 557 lt_lexical_inst_info (InstInfo _ _ _ _ _ dfun1 _ _ _ _ _ _) (InstInfo _ _ _ _ _ dfun2 _ _ _ _ _ _)
 558   = ltLexical dfun1 dfun2
 559 \end{code}
 560
 561 \begin{code}
 562 getMentionedTyConsAndClassesFromInstInfo (InstInfo clas _ ty _ dfun_theta _ _ _ _ _ _ _)
 563   = case (getMentionedTyConsAndClassesFromType ty) of { (ts, cs) ->
 564     case [ c | (c, _) <- dfun_theta ]                 of { theta_classes ->
 565     (ts, (cs `unionBags` listToBag theta_classes) `snocBag` clas)
 566     }}
 567 \end{code}