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