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 Ubiq{-uitous-}
  12
  13 import Bag              ( emptyBag, snocBag, bagToList )
  14 import Class            ( GenClass{-instance NamedThing-} )
  15 import CmdLineOpts      ( opt_ProduceHi )
  16 import HsSyn
  17 import Id               ( GenId{-instance NamedThing/Outputable-} )
  18 import Name             ( nameOrigName, exportFlagOn, nameExportFlag, ExportFlag(..),
  19                           ltLexical, isExported,
  20                           RdrName{-instance Outputable-}
  21                         )
  22 import PprStyle         ( PprStyle(..) )
  23 import PprType          ( TyCon{-instance Outputable-}, GenClass{-ditto-} )
  24 import Pretty           -- quite a bit
  25 import RnHsSyn          ( RenamedHsModule(..), RnName{-instance NamedThing-} )
  26 import RnIfaces         ( VersionInfo(..) )
  27 import TcModule         ( TcIfaceInfo(..) )
  28 import TcInstUtil       ( InstInfo )
  29 import TyCon            ( TyCon{-instance NamedThing-} )
  30 import Util             ( sortLt, assertPanic )
  31
  32 ppSemid x = ppBeside (ppr PprInterface x) ppSemi -- micro util
  33 \end{code}
  34
  35 We have a function @startIface@ to open the output file and put
  36 (something like) ``interface Foo N'' in it.  It gives back a handle
  37 for subsequent additions to the interface file.
  38
  39 We then have one-function-per-block-of-interface-stuff, e.g.,
  40 @ifaceExportList@ produces the @__exports__@ section; it appends
  41 to the handle provided by @startIface@.
  42
  43 \begin{code}
  44 startIface  :: Module
  45             -> IO (Maybe Handle) -- Nothing <=> don't do an interface
  46 endIface    :: Maybe Handle -> IO ()
  47 ifaceVersions
  48             :: Maybe Handle
  49             -> VersionInfo
  50             -> IO ()
  51 ifaceExportList
  52             :: Maybe Handle
  53             -> RenamedHsModule
  54             -> IO ()
  55 ifaceFixities
  56             :: Maybe Handle
  57             -> RenamedHsModule
  58             -> IO ()
  59 ifaceInstanceModules
  60             :: Maybe Handle
  61             -> [Module]
  62             -> IO ()
  63 ifaceDecls  :: Maybe Handle
  64             -> TcIfaceInfo  -- info produced by typechecker, for interfaces
  65             -> IO ()
  66 ifaceInstances
  67             :: Maybe Handle
  68             -> TcIfaceInfo  -- as above
  69             -> IO ()
  70 --ifacePragmas
  71 \end{code}
  72
  73 \begin{code}
  74 startIface mod
  75   = case opt_ProduceHi of
  76       Nothing -> return Nothing -- not producing any .hi file
  77       Just fn ->
  78         openFile fn WriteMode   >>= \ if_hdl ->
  79         hPutStr if_hdl ("interface "++ _UNPK_ mod ++" 1\n") >>
  80         return (Just if_hdl)
  81
  82 endIface Nothing        = return ()
  83 endIface (Just if_hdl)  = hPutStr if_hdl "\n" >> hClose if_hdl
  84 \end{code}
  85
  86 \begin{code}
  87 ifaceVersions Nothing{-no iface handle-} _ = return ()
  88
  89 ifaceVersions (Just if_hdl) version_info
  90   = hPutStr if_hdl "__versions__\nFoo(1)" -- a stub, obviously
  91 \end{code}
  92
  93 \begin{code}
  94 ifaceInstanceModules Nothing{-no iface handle-} _ = return ()
  95 ifaceInstanceModules (Just _)                  [] = return ()
  96
  97 ifaceInstanceModules (Just if_hdl) imods
  98   = hPutStr if_hdl "\n__instance_modules__\n" >>
  99     hPutStr if_hdl (ppShow 100 (ppCat (map ppPStr imods)))
 100 \end{code}
 101
 102 Export list: grab the Names of things that are marked Exported, sort
 103 (so the interface file doesn't ``wobble'' from one compilation to the
 104 next...), and print.  Note that the ``module'' now contains all the
 105 imported things that we are dealing with, thus including any entities
 106 that we are re-exporting from somewhere else.
 107 \begin{code}
 108 ifaceExportList Nothing{-no iface handle-} _ = return ()
 109
 110 ifaceExportList (Just if_hdl)
 111                 (HsModule _ _ _ _ _ typedecls _ classdecls _ _ _ binds sigs _)
 112   = let
 113         name_flag_pairs :: Bag (Name, ExportFlag)
 114         name_flag_pairs
 115           = foldr from_ty
 116            (foldr from_cls
 117            (foldr from_sig
 118            (from_binds binds emptyBag{-init accum-})
 119              sigs)
 120              classdecls)
 121              typedecls
 122
 123         sorted_pairs = sortLt lexical_lt (bagToList name_flag_pairs)
 124
 125     in
 126     hPutStr if_hdl "\n__exports__\n" >>
 127     hPutStr if_hdl (ppShow 100 (ppAboves (map pp_pair sorted_pairs)))
 128   where
 129     from_ty (TyData _ n _ _ _ _ _) acc = maybe_add acc n
 130     from_ty (TyNew  _ n _ _ _ _ _) acc = maybe_add acc n
 131     from_ty (TySynonym n _ _ _)    acc = maybe_add acc n
 132
 133     from_cls (ClassDecl _ n _ _ _ _ _) acc = maybe_add acc n
 134
 135     from_sig (Sig n _ _ _) acc = maybe_add acc n
 136
 137     from_binds bs acc = maybe_add_list acc (collectTopLevelBinders bs)
 138
 139     --------------
 140     maybe_add :: Bag (Name, ExportFlag) -> RnName -> Bag (Name, ExportFlag)
 141
 142     maybe_add acc rn
 143       | exportFlagOn ef = acc `snocBag` (n, ef)
 144       | otherwise       = acc
 145       where
 146         n  = getName rn
 147         ef = nameExportFlag n
 148
 149     --------------
 150     maybe_add_list acc []     = acc
 151     maybe_add_list acc (n:ns) = maybe_add (maybe_add_list acc ns) n
 152
 153     --------------
 154     lexical_lt (n1,_) (n2,_) = nameOrigName n1 < nameOrigName n2
 155
 156     --------------
 157     pp_pair (n, ef)
 158       = ppBeside (ppr PprInterface (nameOrigName n)) (pp_export ef)
 159       where
 160         pp_export ExportAll = ppPStr SLIT("(..)")
 161         pp_export ExportAbs = ppNil
 162 \end{code}
 163
 164 \begin{code}
 165 ifaceFixities Nothing{-no iface handle-} _ = return ()
 166
 167 ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _)
 168   = if null fixities then
 169         return ()
 170     else
 171         hPutStr if_hdl "\n__fixities__\n" >>
 172         hPutStr if_hdl (ppShow 100 (ppAboves (map ppSemid fixities)))
 173 \end{code}
 174
 175 \begin{code}
 176 ifaceDecls Nothing{-no iface handle-} _ = return ()
 177
 178 ifaceDecls (Just if_hdl) (vals, tycons, classes, _)
 179   = ASSERT(not (null vals && null tycons && null classes))
 180     let
 181         exported_classes = filter isExported classes
 182         exported_tycons  = filter isExported tycons
 183         exported_vals    = filter isExported vals
 184
 185         sorted_classes   = sortLt ltLexical exported_classes
 186         sorted_tycons    = sortLt ltLexical exported_tycons
 187         sorted_vals      = sortLt ltLexical exported_vals
 188     in
 189     hPutStr if_hdl "\n__declarations__\n" >>
 190     hPutStr if_hdl (ppShow 100 (ppAboves [
 191         ppAboves (map ppSemid sorted_classes),
 192         ppAboves (map ppSemid sorted_tycons),
 193         ppAboves (map ppSemid sorted_vals)]))
 194 \end{code}
 195
 196 \begin{code}
 197 ifaceInstances Nothing{-no iface handle-} _ = return ()
 198
 199 ifaceInstances (Just if_hdl) (_, _, _, insts)
 200   = return ()
 201 {-
 202     let
 203         exported_classes = filter isExported classes
 204         exported_tycons  = filter isExported tycons
 205         exported_vals    = filter isExported vals
 206
 207         sorted_classes   = sortLt ltLexical exported_classes
 208         sorted_tycons    = sortLt ltLexical exported_tycons
 209         sorted_vals      = sortLt ltLexical exported_vals
 210     in
 211     hPutStr if_hdl "\n__declarations__\n" >>
 212     hPutStr if_hdl (ppShow 100 (ppAboves [
 213         ppAboves (map ppSemid sorted_classes),
 214         ppAboves (map ppSemid sorted_tycons),
 215         ppAboves (map ppSemid sorted_vals)]))
 216 -}
 217 \end{code}
 218
 219 === ALL OLD BELOW HERE ==============
 220
 221 %************************************************************************
 222 %*                                                                      *
 223 \subsection[main-MkIface]{Main routine for making interfaces}
 224 %*                                                                      *
 225 %************************************************************************
 226
 227 Misc points:
 228 \begin{enumerate}
 229 \item
 230 We get the general what-to-export information from the ``environments''
 231 produced by the typechecker (the \tr{[RenamedFixityDecl]} through
 232 \tr{Bag InstInfo} arguments).
 233
 234 \item
 235 {\em However:} Whereas (for example) an \tr{InstInfo} will have
 236 \tr{Ids} in it that identify the constant methods for that instance,
 237 those particular \tr{Ids} {\em do not have} the best @IdInfos@!!!
 238 Those @IdInfos@ were figured out long after the \tr{InstInfo} was
 239 created.
 240
 241 That's why we actually look at the final \tr{StgBindings} that go
 242 into the code-generator: they have the best @IdInfos@ on them.
 243 Whenever, we are about to print info about an @Id@, we look in the
 244 Ids-from-STG-bindings list to see if we have an ``equivalent'' @Id@
 245 with presumably-better @IdInfo@.
 246
 247 \item
 248 We play this same game whether for values, classes (for their
 249 method-selectors and default-methods), or instances (for their
 250 @DictFunIds@ or constant-methods).
 251
 252 Of course, for imported things, what we got from the typechecker is
 253 all we're gonna get.
 254
 255 \item
 256 We {\em sort} things in the interface into some ``canonical'' order;
 257 otherwise, with heavily-recursive modules, you can have (unchanged)
 258 information ``move around'' in the interface file---deeply unfriendly
 259 to \tr{make}.
 260 \end{enumerate}
 261
 262 \begin{code}
 263 {- OLD: to the end
 264 mkInterface :: FAST_STRING
 265             -> (FAST_STRING -> Bool,  -- is something in export list, explicitly?
 266                 FAST_STRING -> Bool)  -- is a module among the "dotdot" exported modules?
 267             -> IdEnv UnfoldingDetails
 268             -> FiniteMap TyCon [(Bool, [Maybe Type])]
 269             -> ([RenamedFixityDecl],  -- interface info from the typecheck
 270                 [Id],
 271                 CE,
 272                 TCE,
 273                 Bag InstInfo)
 274             -> [StgBinding]
 275             -> Pretty
 276
 277 mkInterface modname export_list_fns inline_env tycon_specs
 278             (fixity_decls, global_ids, ce, tce, inst_infos)
 279             stg_binds
 280   = let
 281         -- first, gather up the things we want to export:
 282
 283         exported_tycons  = [ tc | tc <- rngTCE tce,
 284                            isExported tc,
 285                            is_exportable_tycon_or_class export_list_fns tc ]
 286         exported_classes = [  c |  c <- rngCE  ce,
 287                            isExported  c,
 288                            is_exportable_tycon_or_class export_list_fns  c ]
 289         exported_inst_infos = [ i | i <- bagToList inst_infos,
 290                            is_exported_inst_info export_list_fns i ]
 291         exported_vals
 292           = [ v | v <- global_ids,
 293               isExported v && not (isDataCon v) && not (isClassOpId v) ]
 294
 295         -- We also have to worry about TyCons/Classes that are
 296         -- *mentioned* in exported things (e.g., values' types or
 297         -- instances), so that we can be sure to do an import decl for
 298         -- them, for original-naming purposes:
 299
 300         (mentioned_tycons, mentioned_classes)
 301           = foldr ( \ (tcs1, cls1) (tcs2, cls2)
 302                       -> (tcs1 `unionBags` tcs2, cls1 `unionBags` cls2) )
 303                   (emptyBag, emptyBag)
 304                   (map getMentionedTyConsAndClassesFromClass exported_classes  ++
 305                    map getMentionedTyConsAndClassesFromTyCon exported_tycons   ++
 306                    map getMentionedTyConsAndClassesFromId    exported_vals     ++
 307                    map getMentionedTyConsAndClassesFromInstInfo exported_inst_infos)
 308
 309         mentionable_classes
 310           = filter is_mentionable (bagToList mentioned_classes)
 311         mentionable_tycons
 312           = [ tc | tc <- bagToList mentioned_tycons,
 313                    is_mentionable tc,
 314                    not (isPrimTyCon tc) ]
 315
 316         nondup_mentioned_tycons  = fst (removeDups cmp mentionable_tycons)
 317         nondup_mentioned_classes = fst (removeDups cmp mentionable_classes)
 318
 319         -- Next: as discussed in the notes, we want the top-level
 320         -- Ids straight from the final STG code, so we can use
 321         -- their IdInfos to print pragmas; we slurp them out here,
 322         -- then pass them to the printing functions, which may
 323         -- use them.
 324
 325         better_ids = collectExportedStgBinders stg_binds
 326
 327         -- Make a lookup function for convenient access:
 328
 329         better_id_fn i
 330           = if not (isLocallyDefined i)
 331             then i  -- can't be among our "better_ids"
 332             else
 333                let
 334                    eq_fn = if isTopLevId i -- can't trust uniqs
 335                            then (\ x y -> origName x == origName y)
 336                            else eqId
 337                in
 338                case [ x | x <- better_ids, x `eq_fn` i ] of
 339                  []  -> pprPanic "better_id_fn:" (ppr PprShowAll i)
 340                         i
 341                  [x] -> x
 342                  _   -> panic "better_id_fn"
 343
 344         -- Finally, we sort everything lexically, so that we always
 345         -- get the same interface from the same information:
 346
 347         sorted_mentioned_tycons  = sortLt ltLexical nondup_mentioned_tycons
 348         sorted_mentioned_classes = sortLt ltLexical nondup_mentioned_classes
 349
 350         sorted_tycons     = sortLt ltLexical exported_tycons
 351         sorted_classes    = sortLt ltLexical exported_classes
 352         sorted_vals       = sortLt ltLexical exported_vals
 353         sorted_inst_infos = sortLt lt_lexical_inst_info exported_inst_infos
 354     in
 355     if (any_purely_local sorted_tycons sorted_classes sorted_vals) then
 356         -- this will be less of a HACK when we teach
 357         -- mkInterface to do I/O (WDP 94/10)
 358         error "Can't produce interface file because of errors!\n"
 359     else
 360     ppAboves
 361        [ppPStr SLIT("{-# GHC_PRAGMA INTERFACE VERSION 7 #-}"),
 362         ppCat [ppPStr SLIT("interface"), ppPStr modname, ppPStr SLIT("where")],
 363
 364         do_import_decls modname
 365                 sorted_vals sorted_mentioned_classes sorted_mentioned_tycons,
 366                 -- Mustn't give the data constructors to do_import_decls,
 367                 -- because they aren't explicitly imported; their tycon is.
 368
 369         ppAboves (map do_fixity                                 fixity_decls),
 370         ppAboves (map (pprIfaceClass better_id_fn inline_env)   sorted_classes),
 371         ppAboves (map (do_tycon      tycon_specs)               sorted_tycons),
 372         ppAboves (map (do_value      better_id_fn inline_env)   sorted_vals),
 373         ppAboves (map (do_instance   better_id_fn inline_env)   sorted_inst_infos),
 374
 375         ppChar '\n'
 376        ]
 377   where
 378     any_purely_local tycons classes vals
 379       =  any bad_tc tycons || any bad_cl classes || any bad_id vals
 380       where
 381         bad_cl cl
 382           = case (maybePurelyLocalClass cl) of
 383               Nothing -> False
 384               Just xs -> naughty_trace cl xs
 385
 386         bad_id id
 387           = case (maybePurelyLocalType (idType id)) of
 388               Nothing -> False
 389               Just xs -> naughty_trace id xs
 390
 391         bad_tc tc
 392           = case (maybePurelyLocalTyCon tc) of
 393               Nothing -> False
 394               Just xs -> if exported_abs then False else naughty_trace tc xs
 395           where
 396             exported_abs = case (getExportFlag tc) of { ExportAbs -> True; _ -> False }
 397
 398         naughty_trace x things
 399           = pprTrace "Can't export -- `"
 400                 (ppBesides [ppr PprForUser x, ppStr "' mentions purely local things: ",
 401                         ppInterleave pp'SP things])
 402                 True
 403 \end{code}
 404
 405 %************************************************************************
 406 %*                                                                      *
 407 \subsection[imports-MkIface]{Generating `import' declarations in an interface}
 408 %*                                                                      *
 409 %************************************************************************
 410
 411 We gather up lots of (module, name) pairs for which we might print an
 412 import declaration.  We sort them, for the usual canonicalisation
 413 reasons.  NB: We {\em assume} the lists passed in don't have duplicates in
 414 them!  expect).
 415
 416 All rather horribly turgid (WDP).
 417
 418 \begin{code}
 419 do_import_decls
 420         :: FAST_STRING
 421         -> [Id] -> [Class] -> [TyCon]
 422         -> Pretty
 423
 424 do_import_decls mod_name vals classes tycons
 425   = let
 426         -- Conjure up (module, name) pairs for all
 427         -- the potentially import-decls things:
 428
 429         vals_names, classes_names, tycons_names :: [(FAST_STRING, FAST_STRING, [Maybe FAST_STRING])]
 430         vals_names      = map get_val_pair   vals
 431         classes_names   = map get_class_pair classes
 432         tycons_names    = map get_tycon_pair tycons
 433
 434         -- sort the (module, name) pairs and chop
 435         -- them into per-module groups:
 436
 437         ie_list = sortLt lt (tycons_names ++ classes_names ++ vals_names)
 438
 439         per_module_groups = runs same_module ie_list
 440     in
 441     ppAboves (map print_a_decl per_module_groups)
 442   where
 443     lt, same_module :: (FAST_STRING, FAST_STRING)
 444                     -> (FAST_STRING, FAST_STRING) -> Bool
 445
 446     lt (m1, ie1, ie2)
 447       = case (_CMP_STRING_ m1 m2) of { LT_ -> True; EQ_ -> ie1 < ie2; GT__ -> False }
 448
 449     same_module (m1, _, _) (m2, _, _) = m1 == m2
 450
 451     compiling_the_prelude = opt_CompilingPrelude
 452
 453     print_a_decl :: [(FAST_STRING, FAST_STRING, [Maybe FAST_STRING])] -> Pretty
 454     {-
 455         Obviously, if the module in question is this one,
 456         don't print an import declaration.
 457
 458         If it's a Prelude* module, we don't print the TyCons/
 459         Classes, because the compiler supposedly knows about
 460         them already (and they are PreludeCore things anyway).
 461
 462         But if we are compiling a Prelude module, then we
 463         try to do it as "normally" as possible.
 464     -}
 465     print_a_decl (ielist@((m,_,_) : _))
 466       |  m == mod_name
 467       || (not compiling_the_prelude &&
 468           ({-OLD:m == pRELUDE_CORE ||-} m == pRELUDE_BUILTIN))
 469       = ppNil
 470
 471       | otherwise
 472       = ppBesides [ppPStr SLIT("import "), ppPStr m, ppLparen,
 473                    ppIntersperse pp'SP{-'-} (map pp_str [n | (_,n,_) <- ielist]),
 474                    ppRparen
 475                   ]
 476       where
 477         isnt_tycon_ish :: FAST_STRING -> Bool
 478         isnt_tycon_ish str = not (isLexCon str)
 479
 480         grab_non_Nothings :: [[Maybe FAST_STRING]] -> [FAST_STRING]
 481
 482         grab_non_Nothings rns = catMaybes (concat rns)
 483
 484         pp_str :: FAST_STRING -> Pretty
 485         pp_str pstr
 486           = if isLexVarSym pstr then ppStr ("("++str++")") else ppPStr pstr
 487           where
 488             str = _UNPK_ pstr
 489 \end{code}
 490
 491 \begin{code}
 492 get_val_pair   :: Id    -> (FAST_STRING, FAST_STRING)
 493 get_class_pair :: Class -> (FAST_STRING, FAST_STRING)
 494 get_tycon_pair :: TyCon -> (FAST_STRING, FAST_STRING)
 495
 496 get_val_pair id
 497   = generic_pair id
 498
 499 get_class_pair clas
 500   = case (generic_pair clas) of { (orig_mod, orig_nm) ->
 501     let
 502         nm_to_print = case (getExportFlag clas) of
 503                         ExportAll   -> orig_nm _APPEND_ SLIT("(..)") -- nothing like a good HACK!
 504                         ExportAbs   -> orig_nm
 505                         NotExported -> orig_nm
 506     in
 507     (orig_mod, nm_to_print) }
 508
 509 get_tycon_pair tycon
 510   = case (generic_pair tycon) of { (orig_mod, orig_nm) ->
 511     let
 512         nm_to_print = case (getExportFlag tycon) of
 513                         ExportAll   -> orig_nm _APPEND_ SLIT("(..)") -- nothing like a good HACK!
 514                         ExportAbs   -> orig_nm
 515                         NotExported -> orig_nm
 516
 517         cons        = tyConDataCons tycon
 518     in
 519     (orig_mod, nm_to_print) }
 520
 521 generic_pair thing
 522   = case (moduleNamePair       thing) of { (orig_mod, orig_nm) ->
 523     case (getOccName thing) of { occur_name ->
 524     (orig_mod, orig_nm) }}
 525 \end{code}
 526
 527 %************************************************************************
 528 %*                                                                      *
 529 \subsection[fixities-MkIface]{Generating fixity declarations in an interface}
 530 %*                                                                      *
 531 %************************************************************************
 532
 533
 534 \begin{code}
 535 do_fixity :: -> RenamedFixityDecl -> Pretty
 536
 537 do_fixity fixity_decl
 538   = case (isLocallyDefined name, getExportFlag name) of
 539       (True, ExportAll) -> ppr PprInterface fixity_decl
 540       _                 -> ppNil
 541   where
 542      name = get_name fixity_decl
 543      get_name (InfixL n _) = n
 544      get_name (InfixR n _) = n
 545      get_name (InfixN n _) = n
 546 \end{code}
 547
 548 %************************************************************************
 549 %*                                                                      *
 550 \subsection[tycons-MkIface]{Generating tycon declarations in an interface}
 551 %*                                                                      *
 552 %************************************************************************
 553
 554 \begin{code}
 555 do_tycon :: FiniteMap TyCon [(Bool, [Maybe Type])] -> TyCon -> Pretty
 556
 557 do_tycon tycon_specs_map tycon
 558   = pprTyCon PprInterface tycon tycon_specs
 559   where
 560     tycon_specs = map snd (lookupWithDefaultFM tycon_specs_map [] tycon)
 561 \end{code}
 562
 563 %************************************************************************
 564 %*                                                                      *
 565 \subsection[values-MkIface]{Generating a value's signature in an interface}
 566 %*                                                                      *
 567 %************************************************************************
 568
 569 \begin{code}
 570 do_value :: (Id -> Id)
 571          -> IdEnv UnfoldingDetails
 572          -> Id
 573          -> Pretty
 574
 575 do_value better_id_fn inline_env val
 576   = let
 577         sty         = PprInterface
 578         better_val  = better_id_fn val
 579         name_str    = getOccName better_val -- NB: not orig name!
 580
 581         id_info     = getIdInfo better_val
 582
 583         val_ty      = let
 584                          orig_ty  = idType val
 585                          final_ty = idType better_val
 586                       in
 587 --                    ASSERT (orig_ty == final_ty || mkLiftTy orig_ty == final_ty)
 588                       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)
 589                       orig_ty
 590
 591         -- Note: We export the type of the original val
 592         -- The type of an unboxed val will have been *lifted* by the desugarer
 593         -- In this case we export an unlifted type, but id_info which assumes
 594         --   a lifted Id i.e. extracted from better_val (above)
 595         -- The importing module must lift the Id before using the imported id_info
 596
 597         pp_id_info
 598           = if opt_OmitInterfacePragmas
 599             || boringIdInfo id_info
 600             then ppNil
 601             else ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"),
 602                         ppIdInfo sty better_val True{-yes specs-}
 603                             better_id_fn inline_env id_info,
 604                         ppPStr SLIT("#-}")]
 605     in
 606     ppAbove (ppCat [ppr_non_op name_str,
 607                     ppPStr SLIT("::"), pprGenType sty val_ty])
 608             pp_id_info
 609
 610 -- sadly duplicates Name.pprNonSym (ToDo)
 611
 612 ppr_non_op str
 613   = if isLexVarSym str -- NOT NEEDED: || isAconop
 614     then ppBesides [ppLparen, ppPStr str, ppRparen]
 615     else ppPStr str
 616 \end{code}
 617
 618 %************************************************************************
 619 %*                                                                      *
 620 \subsection[instances-MkIface]{Generating instance declarations in an interface}
 621 %*                                                                      *
 622 %************************************************************************
 623
 624 The types of ``dictionary functions'' (dfuns) have just the required
 625 info for instance declarations in interfaces.  However, the dfuns that
 626 GHC really uses have {\em extra} dictionaries passed to them (for
 627 efficiency).  When we print interfaces, we want to omit that
 628 dictionary information.  (It can be reconsituted on the other end,
 629 from instance and class decls).
 630
 631 \begin{code}
 632 do_instance :: (Id -> Id)
 633             -> IdEnv UnfoldingDetails
 634             -> InstInfo
 635             -> Pretty
 636
 637 do_instance better_id_fn inline_env
 638     (InstInfo clas tv_tmpls ty inst_decl_theta dfun_theta dfun_id constm_ids _ from_here modname _ _)
 639   = let
 640         sty = PprInterface
 641
 642         better_dfun      = better_id_fn dfun_id
 643         better_dfun_info = getIdInfo better_dfun
 644         better_constms   = map better_id_fn constm_ids
 645
 646         class_op_strs = map classOpString (classOps clas)
 647
 648         pragma_begin
 649           = ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"), pp_modname, ppPStr SLIT("{-dfun-}"),
 650                    ppIdInfo sty better_dfun False{-NO specs-}
 651                     better_id_fn inline_env better_dfun_info]
 652
 653         pragma_end = ppPStr SLIT("#-}")
 654
 655         pp_modname = if _NULL_ modname
 656                      then ppNil
 657                      else ppCat [ppStr "_M_", ppPStr modname]
 658
 659         name_pragma_pairs
 660           = pp_the_list [ ppCat [ppChar '\t', ppr_non_op op, ppEquals,
 661                                  ppChar '{' ,
 662                                  ppIdInfo sty constm True{-YES, specs-}
 663                                   better_id_fn inline_env
 664                                   (getIdInfo constm),
 665                                  ppChar '}' ]
 666                         | (op, constm) <- class_op_strs `zip` better_constms ]
 667
 668 #ifdef DEBUG
 669         pp_the_list [] = panic "MkIface: no class_ops or better_constms?"
 670 #endif
 671         pp_the_list [p]    = p
 672         pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
 673
 674         real_stuff
 675           = ppCat [ppPStr SLIT("instance"),
 676                    ppr sty (mkSigmaTy tv_tmpls inst_decl_theta (mkDictTy clas ty))]
 677     in
 678     if opt_OmitInterfacePragmas
 679     || boringIdInfo better_dfun_info
 680     then real_stuff
 681     else ppAbove real_stuff
 682           ({-ppNest 8 -} -- ppNest does nothing
 683              if null better_constms
 684              then ppCat [pragma_begin, pragma_end]
 685              else ppAbove pragma_begin (ppCat [name_pragma_pairs, pragma_end])
 686           )
 687 \end{code}
 688
 689 %************************************************************************
 690 %*                                                                      *
 691 \subsection[utils-InstInfos]{Utility functions for @InstInfos@}
 692 %*                                                                      *
 693 %************************************************************************
 694
 695 ToDo: perhaps move.
 696
 697 Classes/TyCons are ``known,'' more-or-less.  Prelude TyCons are
 698 ``completely'' known---they don't need to be mentioned in interfaces.
 699 Classes usually don't need to be mentioned in interfaces, but if we're
 700 compiling the prelude, then we treat them without special favours.
 701 \begin{code}
 702 is_exportable_tycon_or_class export_list_fns tc
 703   = if not (fromPreludeCore tc) then
 704         True
 705     else
 706         in_export_list_or_among_dotdot_modules
 707             opt_CompilingPrelude -- ignore M.. stuff if compiling prelude
 708             export_list_fns tc
 709
 710 in_export_list_or_among_dotdot_modules ignore_Mdotdots (in_export_list, among_dotdot_modules) tc
 711   = if in_export_list (getOccName tc) then
 712         True
 713     else
 714 --      pprTrace "in_export:" (ppAbove (ppr PprDebug ignore_Mdotdots) (ppPStr (getOccName  tc))) (
 715     if ignore_Mdotdots then
 716         False
 717     else
 718         any among_dotdot_modules (getInformingModules tc)
 719 --  )
 720
 721 is_mentionable tc
 722   = not (from_PreludeCore_or_Builtin tc) || opt_CompilingPrelude
 723   where
 724     from_PreludeCore_or_Builtin thing
 725       = let
 726             mod_name = fst (moduleNamePair thing)
 727         in
 728         mod_name == pRELUDE_CORE || mod_name == pRELUDE_BUILTIN
 729
 730 is_exported_inst_info export_list_fns
 731         (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
 732   = let
 733         seems_exported = instanceIsExported clas ty from_here
 734         (tycon, _, _) = getAppTyCon ty
 735     in
 736     if (opt_OmitReexportedInstances && not from_here) then
 737         False -- Flag says to violate Haskell rules, blatantly
 738
 739     else if not opt_CompilingPrelude
 740          || not (isFunTyCon tycon || fromPreludeCore tycon)
 741          || not (fromPreludeCore clas) then
 742         seems_exported -- take what we got
 743
 744     else -- compiling Prelude & tycon/class are Prelude things...
 745         from_here
 746         || in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns clas
 747         || in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns tycon
 748 \end{code}
 749
 750 \begin{code}
 751 lt_lexical_inst_info (InstInfo _ _ _ _ _ dfun1 _ _ _ _ _ _) (InstInfo _ _ _ _ _ dfun2 _ _ _ _ _ _)
 752   = ltLexical dfun1 dfun2
 753 \end{code}
 754
 755 \begin{code}
 756 getMentionedTyConsAndClassesFromInstInfo (InstInfo clas _ ty _ dfun_theta _ _ _ _ _ _ _)
 757   = case (getMentionedTyConsAndClassesFromType ty) of { (ts, cs) ->
 758     case [ c | (c, _) <- dfun_theta ]                 of { theta_classes ->
 759     (ts, (cs `unionBags` listToBag theta_classes) `snocBag` clas)
 760     }}
 761 OLD from the beginning -}
 762 \end{code}