ghc/compiler/rename/Rename1.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[Rename1]{@Rename1@: gather up imported information}
   5
   6 See the @Rename@ module for a basic description of the renamer.
   7
   8 \begin{code}
   9 #include "HsVersions.h"
  10
  11 module Rename1 (
  12         rnModule1,
  13
  14         -- for completeness
  15         Module, Bag, ProtoNamePat(..), InPat, Maybe,
  16         PprStyle, Pretty(..), PrettyRep, ProtoName, Name,
  17         PreludeNameFun(..), PreludeNameFuns(..)
  18     ) where
  19
  20 IMPORT_Trace            -- ToDo: rm
  21 import Pretty           -- these two too
  22 import Outputable
  23
  24 import AbsSyn
  25 import AbsSynFuns       ( getMentionedVars ) -- *** not via AbsSyn ***
  26 import Bag              ( Bag, emptyBag, unitBag, snocBag, unionBags, bagToList )
  27 import Errors
  28 import HsPragmas
  29 import FiniteMap
  30 import Maybes           ( maybeToBool, catMaybes, Maybe(..) )
  31 --OLD: import NameEnv   ( mkStringLookupFn )
  32 import ProtoName        ( ProtoName(..), mkPreludeProtoName )
  33 import RenameAuxFuns
  34 import RenameMonad12
  35 import Util
  36 \end{code}
  37
  38
  39 %************************************************************************
  40 %*                                                                      *
  41 \subsection{Types and things used herein}
  42 %*                                                                      *
  43 %************************************************************************
  44
  45 @AllIntDecls@ is the type returned from processing import statement(s)
  46 in the main module.
  47
  48 \begin{code}
  49 type AllIntDecls = ([ProtoNameFixityDecl], [ProtoNameTyDecl],
  50                     [ProtoNameClassDecl],  [ProtoNameInstDecl],
  51                     [ProtoNameSig], Bag FAST_STRING)
  52 \end{code}
  53
  54 The selective-import function @SelectiveImporter@ maps a @ProtoName@
  55 to something which indicates how much of the thing, if anything, is
  56 wanted by the importing module.
  57 \begin{code}
  58 type SelectiveImporter = ProtoName -> Wantedness
  59
  60 data Wantedness
  61   = Wanted
  62   | NotWanted
  63   | WantedWith IE
  64 \end{code}
  65
  66 The @ProtoNames@ supplied to these ``name functions'' are always
  67 @Unks@, unless they are fully-qualified names, which occur only in
  68 interface pragmas (and, therefore, never on the {\em definitions} of
  69 things).  That doesn't happen in @Rename1@!
  70 \begin{code}
  71 type IntNameFun   = ProtoName -> ProtoName
  72 type IntTCNameFun = ProtoName -> (ProtoName, IntNameFun)
  73 \end{code}
  74
  75 %************************************************************************
  76 %*                                                                      *
  77 \subsection{First pass over the entire module}
  78 %*                                                                      *
  79 %************************************************************************
  80
  81 This pass flattens out the declarations embedded within the interfaces
  82 which this module imports.  The result is a new module with no
  83 imports, but with more declarations.  The declarations which arose
  84 from the imported interfaces will have @ProtoNames@ with @Imp@
  85 constructors; the declarations in the body of this module are
  86 unaffected, so they will still be @Unk@'s.
  87
  88 We import only the declarations from interfaces which are actually {\em
  89 used}.  This saves time later, because we don't need process the
  90 unused ones.
  91
  92 \begin{code}
  93 rnModule1 :: PreludeNameFuns
  94           -> Bool               -- see use below
  95           -> ProtoNameModule
  96           -> Rn12M (ProtoNameModule, [FAST_STRING])
  97
  98 rnModule1 pnf@(v_pnf, tc_pnf)
  99         use_mentioned_vars_heuristic
 100         (Module mod_name exports imports fixes
 101                 ty_decls absty_sigs class_decls inst_decls specinst_sigs
 102                 defaults binds _ src_loc)
 103
 104   =     -- slurp through the *body* of the module, collecting names of
 105         -- mentioned *variables*, 3+ letters long & not prelude names.
 106         -- Note: we *do* have to pick up top-level binders,
 107         -- so we can check for conflicts with imported guys!
 108     let
 109 {- OLD:MENTIONED-}
 110         (uses_Mdotdot_in_exports, mentioned_vars)
 111           = getMentionedVars v_pnf exports fixes class_decls inst_decls binds
 112
 113         -- Using the collected "mentioned" variables, create an
 114         -- "is-mentioned" function (:: FAST_STRING -> Bool), which gives
 115         -- True if something is mentioned is in the list collected.
 116         -- For more details, see under @selectAll@, notably the
 117         -- handling of short (< 3 chars) names.
 118
 119         -- Note: this "is_mentioned" game doesn't work if the export
 120         -- list includes any M.. constructs (because that mentions
 121         -- variables *implicitly*, basically).  getMentionedVars tells
 122         -- us this, and we act accordingly.
 123
 124         is_mentioned_maybe
 125           = lookupFM {-OLD: mkStringLookupFn-} (listToFM
 126                 [ (x, panic "is_mentioned_fn")
 127                 | x <- mentioned_vars ++ needed_for_deriving ]
 128                 )
 129                 -- OLD: False{-not-sorted-}
 130           where
 131             needed_for_deriving -- is this a HACK or what?
 132               = [ SLIT("&&"),
 133                   SLIT("."),
 134                   SLIT("lex"),
 135                   SLIT("map"),
 136                   SLIT("not"),
 137                   SLIT("readParen"),
 138                   SLIT("showParen"),
 139                   SLIT("showSpace__"),
 140                   SLIT("showString")
 141                 ]
 142
 143         is_mentioned_fn
 144           = if use_mentioned_vars_heuristic
 145             && not (uses_Mdotdot_in_exports)
 146             then \ x -> maybeToBool (is_mentioned_maybe x)
 147             else \ x -> True
 148 {- OLD:MENTIONED-}
 149 --O:M   is_mentioned_fn = \ x -> True -- ToDo: delete altogether
 150     in
 151         -- OK, now do the business:
 152     doImportedIfaces pnf is_mentioned_fn imports
 153                  `thenRn12`  \ (int_fixes, int_ty_decls,
 154                                 int_class_decls, int_inst_decls,
 155                                 int_sigs, import_names) ->
 156     let
 157         inst_decls' = doRevoltingInstDecls tc_nf inst_decls
 158     in
 159     returnRn12
 160          ((Module mod_name
 161                 exports imports -- passed along mostly for later checking
 162                 (int_fixes        ++ fixes)
 163                 (int_ty_decls     ++ ty_decls)
 164                 absty_sigs
 165                 (int_class_decls ++ class_decls)
 166                 (int_inst_decls  ++ inst_decls')
 167                 specinst_sigs
 168                 defaults
 169                 binds
 170                 int_sigs
 171                 src_loc),
 172           bagToList import_names)
 173   where
 174     -- This function just spots prelude names
 175     tc_nf pname@(Unk s) = case (tc_pnf s) of
 176                            Nothing   -> pname
 177                            Just name -> Prel name
 178
 179     tc_nf other_pname   = panic "In tc_nf passed to doRevoltingInstDecls"
 180         -- The only place where Imps occur is on Ids in unfoldings;
 181         -- this function is only used on type-things.
 182 \end{code}
 183
 184 Instance declarations in the module itself are treated in a horribly
 185 special way.  Because their class name and type constructor will be
 186 compared against imported ones in the second pass (to eliminate
 187 duplicate instance decls) we need to make Prelude classes and tycons
 188 appear as such.  (For class and type decls, the module can't be
 189 declaring a prelude class or tycon, so Prel and Unk things can just
 190 compare non-equal.)  This is a HACK.
 191
 192 \begin{code}
 193 doRevoltingInstDecls :: IntNameFun -> [ProtoNameInstDecl] -> [ProtoNameInstDecl]
 194
 195 doRevoltingInstDecls tc_nf decls
 196   = map revolt_me decls
 197   where
 198     revolt_me (InstDecl context cname ty binds True modname imod uprags pragma src_loc)
 199       = InstDecl
 200             context                     -- Context unchanged
 201             (tc_nf cname)               -- Look up the class
 202             (doIfaceMonoType1 tc_nf ty) -- Ditto the type
 203             binds                       -- Binds unchanged
 204             True
 205             modname
 206             imod
 207             uprags
 208             pragma
 209             src_loc
 210 \end{code}
 211
 212 %************************************************************************
 213 %*                                                                      *
 214 \subsection{Process a module's imported interfaces}
 215 %*                                                                      *
 216 %************************************************************************
 217
 218 @doImportedIfaces@ processes the entire set of interfaces imported by the
 219 module being renamed.
 220
 221 \begin{code}
 222 doImportedIfaces :: PreludeNameFuns
 223               -> (FAST_STRING -> Bool)
 224               -> [ProtoNameImportedInterface]
 225               -> Rn12M AllIntDecls
 226
 227 doImportedIfaces pnfs is_mentioned_fn []
 228   = returnRn12 ( [{-fixities-}],  [{-tydecls-}], [{-clasdecls-}],
 229                  [{-instdecls-}], [{-sigs-}], emptyBag )
 230
 231 doImportedIfaces pnfs is_mentioned_fn (iface:ifaces)
 232   = doOneIface  pnfs is_mentioned_fn iface
 233                          `thenRn12` \ (ifixes1, itd1, icd1, iid1, isd1, names1) ->
 234
 235     doImportedIfaces pnfs is_mentioned_fn ifaces
 236                          `thenRn12` \ (ifixes2, itd2, icd2, iid2, isd2, names2) ->
 237
 238     returnRn12 (ifixes1 ++ ifixes2,
 239                 itd1 ++ itd2,
 240                 icd1 ++ icd2,
 241                 iid1 ++ iid2,
 242                 isd1 ++ isd2,
 243                 names1 `unionBags` names2)
 244 \end{code}
 245
 246 \begin{code}
 247 doOneIface pnfs is_mentioned_fn (ImportAll int renamings)
 248   = let
 249         renaming_fn = mkRenamingFun renamings
 250         -- if there are any renamings, then we don't use
 251         -- the "is_mentioned_fn" hack; possibly dangerous (paranoia reigns)
 252         revised_is_mentioned_fn
 253           = if null renamings
 254             then is_mentioned_fn
 255             else (\ x -> True) -- pretend everything is mentioned
 256     in
 257 --  pprTrace "ImportAll:mod_rns:" (ppr PprDebug renamings) (
 258     doIface1 renaming_fn pnfs (selectAll renaming_fn revised_is_mentioned_fn) int
 259 --  )
 260
 261 doOneIface pnfs unused_is_mentioned_fn (ImportSome int ie_list renamings)
 262   = --pprTrace "ImportSome:mod_rns:" (ppr PprDebug renamings) (
 263     doIface1 (mkRenamingFun renamings) pnfs si_fun int
 264     --)
 265   where
 266     -- the `selective import' function should not be applied
 267     -- to the Imps that occur on Ids in unfoldings.
 268
 269     si_fun (Unk str) = check_ie str ie_list
 270     si_fun other     = panic "si_fun in doOneIface"
 271
 272     check_ie name [] = NotWanted
 273     check_ie name (ie:ies)
 274       = case ie of
 275               IEVar n             | name == n -> Wanted
 276               IEThingAbs n        | name == n -> WantedWith ie
 277               IEThingAll n        | name == n -> WantedWith ie
 278               IEConWithCons n ns  | name == n -> WantedWith ie
 279               IEClsWithOps n ns   | name == n -> WantedWith ie
 280               IEModuleContents _              -> panic "Module.. in import list?"
 281               other                           -> check_ie name ies
 282
 283 doOneIface pnfs unused_is_mentioned_fn (ImportButHide int ie_list renamings)
 284   = --pprTrace "ImportButHide:mod_rns:" (ppr PprDebug renamings) (
 285     doIface1 (mkRenamingFun renamings) pnfs si_fun int
 286     --)
 287   where
 288     -- see comment above:
 289
 290     si_fun (Unk str) | str `elemFM` entity_info = NotWanted
 291                      | otherwise                = Wanted
 292
 293     entity_info = fst (getIEStrings ie_list)
 294 \end{code}
 295
 296 @selectAll@ ``normally'' creates an @SelectiveImporter@ that declares
 297 everything from an interface to be @Wanted@.  We may, however, pass
 298 in a more discriminating @is_mentioned_fn@ (returns @True@ if the
 299 named entity is mentioned in the body of the module in question), which
 300 can be used to trim off junk from an interface.
 301
 302 For @selectAll@ to say something is @NotWanted@, it must be a
 303 variable, it must not be in the collected-up list of mentioned
 304 variables (checked with @is_mentioned_fn@), and it must be three chars
 305 or longer.
 306
 307 And, of course, we mustn't forget to take account of renaming!
 308
 309 ADR Question: What's so magical about names longer than 3 characters?
 310 Why would we want to keep long names which aren't mentioned when we're
 311 quite happy to throw away short names that aren't mentioned?
 312
 313 \begin{code}
 314 selectAll :: (FAST_STRING -> FAST_STRING) -> (FAST_STRING -> Bool) -> SelectiveImporter
 315
 316 selectAll renaming_fn is_mentioned_fn (Unk str) -- gotta be an Unk
 317   = let
 318         rn_str = renaming_fn str
 319     in
 320     if (isAvarid rn_str)
 321     && (not (is_mentioned_fn rn_str))
 322     && (_UNPK_ rn_str `lengthExceeds` 2)
 323     then NotWanted
 324     else Wanted
 325 \end{code}
 326
 327
 328 %************************************************************************
 329 %*                                                                      *
 330 \subsection{First pass over a particular interface}
 331 %*                                                                      *
 332 %************************************************************************
 333
 334
 335 @doIface1@ handles a specific interface. First it looks at the
 336 interface imports, creating a bag that maps local names back to their
 337 original names, from which it makes a function that does the same. It
 338 then uses this function to create a triple of bags for the interface
 339 type, class and value declarations, in which local names have been
 340 mapped back into original names.
 341
 342 Notice that @mkLocalNameFun@ makes two different functions. The first
 343 is the name function for the interface. This takes a local name and
 344 provides an original name for any name in the interface by using
 345 either of:
 346 \begin{itemize}
 347 \item
 348 the original name produced by the renaming function;
 349 \item
 350 the local name in the interface and the interface name.
 351 \end{itemize}
 352
 353 The function @doIfaceImports1@ receives two association lists which will
 354 be described at its definition.
 355
 356 \begin{code}
 357 doIface1 :: (FAST_STRING -> FAST_STRING)    -- Renamings in import stmt of module
 358        -> PreludeNameFuns
 359        -> SelectiveImporter
 360        -> ProtoNameInterface
 361        -> Rn12M AllIntDecls
 362
 363 doIface1 mod_rn_fn (v_pnf, tc_pnf) sifun
 364        (MkInterface i_name import_decls fix_decls ty_decls class_decls
 365                     inst_decls sig_decls anns)
 366
 367   = doIfaceImports1 mod_rn_fn i_name import_decls       `thenRn12` \ (v_bag, tc_bag) ->
 368     do_body (v_bag, tc_bag)
 369   where
 370     do_body (v_bag, tc_bag)
 371       = report_all_errors                       `thenRn12` \ _ ->
 372
 373         doIfaceTyDecls1 sifun full_tc_nf ty_decls       `thenRn12` \ ty_decls' ->
 374
 375         doIfaceClassDecls1 sifun full_tc_nf class_decls  `thenRn12` \ class_decls' ->
 376
 377         let sig_decls'  = doIfaceSigs1 sifun v_nf tc_nf sig_decls
 378             fix_decls'  = doIfaceFixes1 sifun v_nf fix_decls
 379             inst_decls' = doIfaceInstDecls1 sifun tc_nf inst_decls
 380         in
 381         returnRn12 (fix_decls', ty_decls', class_decls', inst_decls', sig_decls', unitBag i_name)
 382       where
 383         v_dups  :: [[(FAST_STRING, ProtoName)]]
 384         tc_dups :: [[(FAST_STRING, (ProtoName, IntNameFun))]]
 385
 386         (imp_v_nf, v_dups)   = mkNameFun {-OLD:v_pnf-}  v_bag
 387         (imp_tc_nf, tc_dups) = mkNameFun {-OLD:tc_pnf-} tc_bag
 388
 389         v_nf :: IntNameFun
 390         v_nf (Unk s) = case v_pnf s of
 391                          Just n  -> mkPreludeProtoName n
 392                          Nothing -> case imp_v_nf s of
 393                                       Just n  -> n
 394                                       Nothing -> Imp i_name s [i_name] (mod_rn_fn s)
 395
 396         prel_con_or_op_nf  :: FAST_STRING{-module name-}-> IntNameFun
 397                  -- Used for (..)'d parts of prelude datatype/class decls;
 398                  -- OLD:? For `data' types, we happen to know everything;
 399                  -- OLD:? For class decls, we *don't* know what the class-ops are.
 400         prel_con_or_op_nf m (Unk s)
 401           = case v_pnf s of
 402               Just n  -> mkPreludeProtoName n
 403               Nothing -> Imp m s [m] (mod_rn_fn s)
 404                          -- Strictly speaking, should be *no renaming* here, folks
 405
 406         local_con_or_op_nf :: IntNameFun
 407                 -- used for non-prelude constructors/ops
 408         local_con_or_op_nf (Unk s) = Imp i_name s [i_name] (mod_rn_fn s)
 409
 410         full_tc_nf :: IntTCNameFun
 411         full_tc_nf (Unk s)
 412           = case tc_pnf s of
 413               Just n  -> (mkPreludeProtoName n,
 414                           let
 415                               mod = fst (getOrigName n)
 416                           in
 417                           prel_con_or_op_nf mod)
 418
 419               Nothing -> case imp_tc_nf s of
 420                           Just pair -> pair
 421                           Nothing   -> (Imp i_name s [i_name] (mod_rn_fn s),
 422                                         local_con_or_op_nf)
 423
 424         tc_nf = fst . full_tc_nf
 425
 426         -- ADR: commented out next new lines because I don't believe
 427         -- ADR: the check is useful or required by the Standard. (It
 428         -- ADR: also messes up the interpreter.)
 429
 430         tc_errs = [] -- map (map (fst . snd)) tc_dups
 431                   -- Ugh! Just keep the dup'd protonames
 432         v_errs  = [] -- map (map snd) v_dups
 433                   -- Ditto
 434
 435         report_all_errors
 436           = mapRn12 (addErrRn12 . duplicateImportsInInterfaceErr (_UNPK_ i_name))
 437                     (tc_errs ++ v_errs)
 438 \end{code}
 439
 440
 441 %************************************************************************
 442 %*                                                                      *
 443 \subsection{doIfaceImports1}
 444 %*                                                                      *
 445 %************************************************************************
 446
 447 @ImportNameBags@ is a pair of bags (one for values, one for types and
 448 classes) which specify the new names brought into scope by some
 449 import declarations in an interface.
 450
 451 \begin{code}
 452 type ImportNameBags = (Bag (FAST_STRING, ProtoName),
 453                        Bag (FAST_STRING, (ProtoName, IntNameFun))
 454                       )
 455 \end{code}
 456
 457 \begin{code}
 458 doIfaceImports1
 459         :: (FAST_STRING -> FAST_STRING) -- Renamings in import stmt of module
 460         -> FAST_STRING                  -- name of module whose interface we're doing
 461         -> [IfaceImportDecl]
 462         -> Rn12M ImportNameBags
 463
 464 doIfaceImports1 _ _  [] = returnRn12 (emptyBag, emptyBag)
 465
 466 doIfaceImports1 mod_rn_fn int_mod_name (imp_decl1 : rest)
 467   = do_decl                              imp_decl1  `thenRn12` \ (vb1, tcb1) ->
 468     doIfaceImports1 mod_rn_fn int_mod_name rest     `thenRn12` \ (vb2, tcb2) ->
 469 --  pprTrace "vbags/tcbags:" (ppr PprDebug (vb1 `unionBags` vb2, [(s,p) | (s,(p,_)) <- bagToList (tcb1 `unionBags` tcb2)])) (
 470     returnRn12 (vb1 `unionBags` vb2, tcb1 `unionBags` tcb2)
 471 --  )
 472   where
 473     do_decl (IfaceImportDecl orig_mod_name imports renamings src_loc)
 474       =         -- Look at the renamings to get a suitable renaming function
 475         doRenamings mod_rn_fn int_mod_name orig_mod_name renamings
 476                                     `thenRn12` \ (orig_to_pn, local_to_pn) ->
 477
 478             -- Now deal with one import at a time, combining results.
 479         returnRn12 (
 480           foldl (doIfaceImport1 orig_to_pn local_to_pn)
 481                 (emptyBag, emptyBag)
 482                 imports
 483         )
 484 \end{code}
 485
 486 @doIfaceImport1@ takes a list of imports and the pair of renaming functions,
 487 returning a bag which maps local names to original names.
 488
 489 \begin{code}
 490 doIfaceImport1 :: ( FAST_STRING     -- Original local name
 491                  -> (FAST_STRING,   -- Local name in this interface
 492                      ProtoName)     -- Its full protoname
 493                 )
 494
 495              -> IntNameFun          -- Local name to ProtoName; use for
 496                                     --   constructors and class ops
 497
 498              -> ImportNameBags      -- Accumulator
 499              -> IE                  -- An item in the import list
 500              -> ImportNameBags
 501
 502 doIfaceImport1 orig_to_pn local_to_pn (v_bag, tc_bag) (IEVar orig_name)
 503   = (v_bag `snocBag` (orig_to_pn orig_name), tc_bag)
 504
 505 doIfaceImport1 orig_to_pn local_to_pn acc (IEThingAbs orig_name)
 506   = int_import1_help orig_to_pn local_to_pn acc orig_name
 507
 508 doIfaceImport1 orig_to_pn local_to_pn acc (IEThingAll orig_name)
 509   = int_import1_help orig_to_pn local_to_pn acc orig_name
 510
 511 doIfaceImport1 orig_to_pn local_to_pn (v_bag, tc_bag) other
 512   = panic "Rename1: strange import decl"
 513
 514 -- Little help guy...
 515
 516 int_import1_help orig_to_pn local_to_pn (v_bag, tc_bag) orig_name
 517   = case (orig_to_pn orig_name) of { (str, o_name) ->
 518     (v_bag, tc_bag `snocBag` (str, (o_name, local_to_pn)))
 519     }
 520 \end{code}
 521
 522
 523 The renaming-processing code.  It returns two name-functions. The
 524 first maps the {\em original} name for an entity onto a @ProtoName@
 525 --- it is used when running over the list of things to be imported.
 526 The second maps the {\em local} name for a constructor or class op
 527 back to its original name --- it is used when scanning the RHS of
 528 a @data@ or @class@ decl.
 529
 530 It can produce errors, if there is a domain clash on the renamings.
 531
 532 \begin{code}
 533 --pprTrace
 534 --instance Outputable _PackedString where
 535 --    ppr sty s = ppStr (_UNPK_ s)
 536
 537 doRenamings :: (FAST_STRING -> FAST_STRING) -- Renamings in import stmt of module
 538             -> FAST_STRING      -- Name of the module whose interface we're working on
 539             -> FAST_STRING      -- Original-name module for these renamings
 540             -> [Renaming]       -- Renamings
 541             -> Rn12M
 542                 ((FAST_STRING        -- Original local name to...
 543                     -> (FAST_STRING, -- ... Local name in this interface
 544                         ProtoName)   -- ... Its full protoname
 545                  ),
 546                  IntNameFun)         -- Use for constructors, class ops
 547
 548 doRenamings mod_rn_fn int_mod orig_mod []
 549   = returnRn12 (
 550       \ s ->
 551         let
 552             result = (s, Imp orig_mod s [int_mod] (mod_rn_fn s))
 553         in
 554 --      pprTrace "name1a:" (ppCat [ppr PprDebug s, ppr PprDebug result]) (
 555         result
 556 --      )
 557         ,
 558
 559       \ (Unk s) ->
 560         let
 561             result = Imp orig_mod s [int_mod] (mod_rn_fn s)
 562         in
 563 --      pprTrace "name2a:" (ppCat [ppr PprDebug s, ppr PprDebug result]) (
 564         result
 565 --      )
 566     )
 567
 568 doRenamings mod_rn_fn int_mod orig_mod renamings
 569   = let
 570         local_rn_fn = mkRenamingFun renamings
 571     in
 572     --pprTrace "local_rns:" (ppr PprDebug renamings) (
 573     returnRn12 (
 574       \ s ->
 575         let
 576             local_name = local_rn_fn s
 577             result
 578               = (local_name, Imp orig_mod s [int_mod] (mod_rn_fn local_name))
 579         in
 580 --      pprTrace "name1:" (ppCat [ppr PprDebug s, ppr PprDebug result]) (
 581         result
 582 --      )
 583         ,
 584
 585       \ (Unk s) ->
 586         let
 587             result
 588               = Imp orig_mod s [int_mod] (mod_rn_fn (local_rn_fn s))
 589         in
 590 --      pprTrace "name2:" (ppCat [ppr PprDebug s, ppr PprDebug result]) (
 591         result
 592 --      )
 593     )
 594     --)
 595 \end{code}
 596
 597 \begin{code}
 598 mkRenamingFun :: [Renaming] -> FAST_STRING -> FAST_STRING
 599
 600 mkRenamingFun []        = \ s -> s
 601 mkRenamingFun renamings
 602   = let
 603         rn_fn = lookupFM (listToFM -- OLD: mkStringLookupFn
 604                   [ (old, new) | MkRenaming old new <- renamings ]
 605                   ) -- OLD: False {-not-sorted-}
 606     in
 607     \s -> case rn_fn s of
 608             Nothing -> s
 609             Just s' -> s'
 610 \end{code}
 611
 612
 613 %************************************************************************
 614 %*                                                                      *
 615 \subsection{Type declarations}
 616 %*                                                                      *
 617 %************************************************************************
 618
 619 @doIfaceTyDecls1@ uses the `name function' to map local tycon names into
 620 original names, calling @doConDecls1@ to do the same for the
 621 constructors. @doTyDecls1@ is used to do both module and interface
 622 type declarations.
 623
 624 \begin{code}
 625 doIfaceTyDecls1 :: SelectiveImporter
 626               -> IntTCNameFun
 627               -> [ProtoNameTyDecl]
 628               -> Rn12M [ProtoNameTyDecl]
 629
 630 doIfaceTyDecls1 sifun full_tc_nf ty_decls
 631   = mapRn12 do_decl ty_decls `thenRn12` \ decls_maybe ->
 632     returnRn12 (catMaybes decls_maybe)
 633   where
 634     do_decl (TyData context tycon tyvars condecls derivs (DataPragmas hidden_cons specs) src_loc)
 635       = let
 636             full_thing = returnRn12 (Just ty_decl')
 637         in
 638                 -- GHC doesn't allow derivings in interfaces
 639         (if null derivs
 640          then returnRn12 ()
 641          else addErrRn12 (derivingInIfaceErr tycon derivs src_loc)
 642         ) `thenRn12` \ _ ->
 643
 644         case (sifun tycon) of
 645           NotWanted                     -> returnRn12 Nothing
 646           Wanted                        -> full_thing
 647           WantedWith (IEThingAll _)     -> full_thing
 648           WantedWith (IEThingAbs _)     -> returnRn12 (Just abs_ty_decl')
 649           WantedWith ie@(IEConWithCons _ _) -> full_thing
 650
 651           WantedWith really_weird_ie -> -- probably a typo in the pgm
 652             addErrRn12 (weirdImportExportConstraintErr
 653                         tycon really_weird_ie src_loc) `thenRn12` \ _ ->
 654             full_thing
 655       where
 656         (tycon_name, constr_nf) = full_tc_nf tycon
 657         tc_nf                   = fst . full_tc_nf
 658
 659         condecls'   = map (do_condecl constr_nf tc_nf) condecls
 660         hidden_cons' = map (do_condecl constr_nf tc_nf) hidden_cons
 661
 662         pragmas' invent_hidden
 663           = DataPragmas (if null hidden_cons && invent_hidden
 664                          then condecls' -- if importing abstractly but condecls were
 665                                         -- exported we add them to the data pragma
 666                          else hidden_cons')
 667                         specs {- ToDo: do_specs -}
 668
 669         context'    = doIfaceContext1 tc_nf context
 670         deriv'      = map tc_nf derivs -- rename derived classes
 671
 672         ty_decl'    = TyData context' tycon_name tyvars condecls' deriv' (pragmas' False) src_loc
 673         abs_ty_decl'= TyData context' tycon_name tyvars []        deriv' (pragmas' True) src_loc
 674
 675     do_decl (TySynonym tycon tyvars monoty pragmas src_loc)
 676       = let
 677             full_thing = returnRn12 (Just ty_decl')
 678         in
 679         case (sifun tycon) of
 680           NotWanted                 -> returnRn12 Nothing
 681           Wanted                    -> full_thing
 682           WantedWith (IEThingAll _) -> full_thing
 683
 684           WantedWith weird_ie       -> full_thing
 685       where
 686         (tycon_name,_) = full_tc_nf tycon
 687         tc_nf   = fst . full_tc_nf
 688         monoty' = doIfaceMonoType1 tc_nf monoty
 689         ty_decl' = TySynonym tycon_name tyvars monoty' pragmas src_loc
 690
 691     -- one name fun for the data constructor, another for the type:
 692
 693     do_condecl c_nf tc_nf (ConDecl name tys src_loc)
 694       = ConDecl (c_nf name) (doIfaceMonoTypes1 tc_nf tys) src_loc
 695 \end{code}
 696
 697 %************************************************************************
 698 %*                                                                      *
 699 \subsection{Class declarations}
 700 %*                                                                      *
 701 %************************************************************************
 702
 703 @doIfaceClassDecls1@ uses the `name function' to map local class names into
 704 original names, calling @doIfaceClassOp1@ to do the same for the
 705 class operations. @doClassDecls1@ is used to process both module and
 706 interface class declarations.
 707
 708 \begin{code}
 709 doIfaceClassDecls1 ::  SelectiveImporter
 710                  -> IntTCNameFun
 711                  -> [ProtoNameClassDecl]
 712                  -> Rn12M [ProtoNameClassDecl]
 713
 714 doIfaceClassDecls1 sifun full_tc_nf clas_decls
 715   = mapRn12 do_decl clas_decls `thenRn12` \ decls_maybe ->
 716     returnRn12 (catMaybes decls_maybe)
 717   where
 718     do_decl (ClassDecl ctxt cname tyvar sigs bs@EmptyMonoBinds prags locn)
 719                                      -- No defaults in interface
 720       = let
 721             full_thing = returnRn12 (Just class_decl')
 722         in
 723         case (sifun cname) of
 724           NotWanted                     -> returnRn12 Nothing
 725           Wanted                        -> full_thing
 726           WantedWith (IEThingAll _)     -> full_thing
 727 --???     WantedWith (IEThingAbs _)     -> returnRn12 (Just abs_class_decl')
 728           WantedWith (IEClsWithOps _ _) -> full_thing
 729           -- ToDo: add checking of IEClassWithOps
 730           WantedWith really_weird_ie    -> -- probably a typo in the pgm
 731             addErrRn12 (weirdImportExportConstraintErr
 732                         cname really_weird_ie locn) `thenRn12` \ _ ->
 733             full_thing
 734       where
 735         (clas, op_nf) = full_tc_nf cname
 736         tc_nf = fst . full_tc_nf
 737
 738         sigs' = map (doIfaceClassOp1 op_nf tc_nf) sigs
 739         ctxt' = doIfaceContext1 tc_nf ctxt
 740
 741         class_decl'     = ClassDecl ctxt' clas tyvar sigs' bs prags locn
 742         abs_class_decl' = ClassDecl ctxt' clas tyvar []    bs prags locn
 743 \end{code}
 744
 745 \begin{code}
 746 doIfaceClassOp1 :: IntNameFun   -- Use this for the class ops
 747               -> IntNameFun     -- Use this for the types
 748               -> ProtoNameClassOpSig
 749               -> ProtoNameClassOpSig
 750
 751 doIfaceClassOp1 op_nf tc_nf (ClassOpSig v ty pragma src_loc)
 752   = ClassOpSig (op_nf v) (doIfacePolyType1 tc_nf ty) pragma src_loc
 753 \end{code}
 754
 755 %************************************************************************
 756 %*                                                                      *
 757 \subsection{Instance declarations}
 758 %*                                                                      *
 759 %************************************************************************
 760
 761 We select the instance decl if either the class or the type constructor
 762 are selected.
 763
 764 \begin{code}
 765 doIfaceInstDecls1 :: SelectiveImporter
 766                 -> IntNameFun
 767                 -> [ProtoNameInstDecl]
 768                 -> [ProtoNameInstDecl]
 769
 770 doIfaceInstDecls1 si tc_nf inst_decls
 771   = catMaybes (map do_decl inst_decls)
 772   where
 773     do_decl (InstDecl context cname ty EmptyMonoBinds False modname imod uprags pragmas src_loc)
 774       = case (si cname, tycon_reqd) of
 775           (NotWanted, NotWanted) -> Nothing
 776           _                      -> Just inst_decl'
 777      where
 778        context' = doIfaceContext1        tc_nf context
 779        ty'      = doIfaceMonoType1 tc_nf ty
 780
 781        inst_decl' = InstDecl context' (tc_nf cname) ty' EmptyMonoBinds False modname imod uprags pragmas src_loc
 782
 783        tycon_reqd
 784          = case getNonPrelOuterTyCon ty of
 785              Nothing -> NotWanted    -- Type doesn't have a user-defined tycon
 786                                      -- at its outermost level
 787              Just tycon -> si tycon  -- It does, so look up in the si-fun
 788 \end{code}
 789
 790 %************************************************************************
 791 %*                                                                      *
 792 \subsection{Signature declarations}
 793 %*                                                                      *
 794 %************************************************************************
 795
 796 @doIfaceSigs1@ uses the name function to create a bag that
 797 maps local names into original names.
 798
 799 NB: Can't have user-pragmas & other weird things in interfaces.
 800
 801 \begin{code}
 802 doIfaceSigs1 :: SelectiveImporter -> IntNameFun -> IntNameFun
 803            -> [ProtoNameSig]
 804            -> [ProtoNameSig]
 805
 806 doIfaceSigs1 si v_nf tc_nf sigs
 807   = catMaybes (map do_sig sigs)
 808   where
 809     do_sig (Sig v ty pragma src_loc)
 810       = case (si v) of
 811           NotWanted -> Nothing
 812           Wanted    -> Just (Sig (v_nf v) (doIfacePolyType1 tc_nf ty) pragma src_loc)
 813           -- WantedWith doesn't make sense
 814 \end{code}
 815
 816
 817 %************************************************************************
 818 %*                                                                      *
 819 \subsection{Fixity declarations}
 820 %*                                                                      *
 821 %************************************************************************
 822
 823 \begin{code}
 824 doIfaceFixes1 :: SelectiveImporter -> IntNameFun
 825             -> [ProtoNameFixityDecl]
 826             -> [ProtoNameFixityDecl]
 827
 828 doIfaceFixes1 si vnf fixities
 829   = catMaybes (map do_fixity fixities)
 830   where
 831     do_fixity (InfixL name i) = do_one InfixL name i
 832     do_fixity (InfixR name i) = do_one InfixR name i
 833     do_fixity (InfixN name i) = do_one InfixN name i
 834
 835     do_one con name i
 836       = case si name of
 837           Wanted    -> Just (con (vnf name) i)
 838           NotWanted -> Nothing
 839 \end{code}
 840
 841
 842 %************************************************************************
 843 %*                                                                      *
 844 \subsection{doContext, MonoTypes, MonoType, Polytype}
 845 %*                                                                      *
 846 %************************************************************************
 847
 848 \begin{code}
 849 doIfacePolyType1 :: IntNameFun -> ProtoNamePolyType -> ProtoNamePolyType
 850
 851 doIfacePolyType1 tc_nf (UnoverloadedTy ty)
 852   = UnoverloadedTy (doIfaceMonoType1 tc_nf ty)
 853
 854 doIfacePolyType1 tc_nf (OverloadedTy ctxt ty)
 855   = OverloadedTy (doIfaceContext1 tc_nf ctxt) (doIfaceMonoType1 tc_nf ty)
 856 \end{code}
 857
 858 \begin{code}
 859 doIfaceContext1 :: IntNameFun -> ProtoNameContext -> ProtoNameContext
 860 doIfaceContext1 tc_nf  context = [(tc_nf clas, tyvar) | (clas,tyvar) <- context]
 861 \end{code}
 862
 863
 864 \begin{code}
 865 doIfaceMonoTypes1 :: IntNameFun -> [ProtoNameMonoType] -> [ProtoNameMonoType]
 866 doIfaceMonoTypes1 tc_nf tys = map (doIfaceMonoType1 tc_nf) tys
 867 \end{code}
 868
 869
 870 \begin{code}
 871 doIfaceMonoType1 :: IntNameFun -> ProtoNameMonoType -> ProtoNameMonoType
 872
 873 doIfaceMonoType1 tc_nf (MonoTyVar tyvar) = MonoTyVar tyvar
 874
 875 doIfaceMonoType1 tc_nf (ListMonoTy ty)
 876   = ListMonoTy (doIfaceMonoType1 tc_nf ty)
 877
 878 doIfaceMonoType1 tc_nf (FunMonoTy ty1 ty2)
 879   = FunMonoTy (doIfaceMonoType1 tc_nf ty1) (doIfaceMonoType1 tc_nf ty2)
 880
 881 doIfaceMonoType1 tc_nf (TupleMonoTy tys)
 882   = TupleMonoTy (map (doIfacePolyType1 tc_nf) tys)
 883
 884 doIfaceMonoType1 tc_nf (MonoTyCon name tys)
 885   = MonoTyCon (tc_nf name) (doIfaceMonoTypes1 tc_nf tys)
 886
 887 #ifdef DPH
 888 doIfaceMonoType1 tc_nf (MonoTyProc tys ty)
 889   = MonoTyProc (doIfaceMonoTypes1 tc_nf tys) (doIfaceMonoType1 tc_nf ty)
 890
 891 doIfaceMonoType1 tc_nf (MonoTyPod ty)
 892   = MonoTyPod (doIfaceMonoType1 tc_nf ty)
 893 #endif {- Data Parallel Haskell -}
 894 \end{code}