[project @ 1996-01-08 20:28:12 by partain]
[ghc.git] / 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}