ghc/compiler/rename/RnIfaces.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[RnIfaces]{Cacheing and Renaming of Interfaces}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module RnIfaces (
  10         findHiFiles,
  11         cachedIface,
  12         cachedDecl,
  13         readIface,
  14         rnIfaces,
  15         finalIfaceInfo,
  16         IfaceCache(..),
  17         VersionInfo(..)
  18     ) where
  19
  20 import Ubiq
  21
  22 import LibDirectory
  23 import PreludeGlaST     ( thenPrimIO, seqPrimIO, readVar, writeVar, MutableVar(..) )
  24
  25 import HsSyn
  26 import HsPragmas        ( noGenPragmas )
  27 import RdrHsSyn
  28 import RnHsSyn
  29
  30 import RnMonad
  31 import RnSource         ( rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType )
  32 import RnUtils          ( RnEnv(..), emptyRnEnv, lookupRnEnv, lookupTcRnEnv, extendGlobalRnEnv )
  33 import ParseIface       ( parseIface )
  34 import ParseUtils       ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..) )
  35
  36 import Bag              ( emptyBag, consBag, snocBag, unionBags, unionManyBags, isEmptyBag, bagToList )
  37 import CmdLineOpts      ( opt_HiSuffix, opt_SysHiSuffix )
  38 import ErrUtils         ( Error(..), Warning(..) )
  39 import FiniteMap        ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM,
  40                           fmToList, delListFromFM, sizeFM, keysFM{-ToDo:rm-} )
  41 import Maybes           ( maybeToBool )
  42 import Name             ( moduleNamePair, origName, isRdrLexCon,
  43                           RdrName(..){-instance NamedThing-}
  44                         )
  45 import PprStyle         -- ToDo:rm
  46 import Outputable       -- ToDo:rm
  47 import PrelInfo         ( builtinNameInfo )
  48 import Pretty
  49 import Maybes           ( MaybeErr(..) )
  50 import UniqFM           ( emptyUFM )
  51 import UniqSupply       ( splitUniqSupply )
  52 import Util             ( sortLt, removeDups, cmpPString, startsWith,
  53                           panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} )
  54 \end{code}
  55
  56 \begin{code}
  57 type ModuleToIfaceContents = FiniteMap Module ParsedIface
  58 type ModuleToIfaceFilePath = FiniteMap Module FilePath
  59
  60 type IfaceCache
  61   = MutableVar _RealWorld (ModuleToIfaceContents,
  62                            ModuleToIfaceFilePath)
  63 \end{code}
  64
  65 *********************************************************
  66 *                                                       *
  67 \subsection{Looking for interface files}
  68 *                                                       *
  69 *********************************************************
  70
  71 Return a mapping from module-name to
  72 absolute-filename-for-that-interface.
  73 \begin{code}
  74 findHiFiles :: [FilePath] -> [FilePath] -> IO (FiniteMap Module FilePath)
  75
  76 findHiFiles dirs sysdirs
  77   = do_dirs emptyFM (dirs ++ sysdirs)
  78   where
  79     do_dirs env [] = return env
  80     do_dirs env (dir:dirs)
  81       = do_dir  env     dir     >>= \ new_env ->
  82         do_dirs new_env dirs
  83     -------
  84     do_dir env dir
  85       = --trace ("Having a go on..."++dir) $
  86         getDirectoryContents dir    >>= \ entries ->
  87         do_entries env entries
  88       where
  89         do_entries env [] = return env
  90         do_entries env (e:es)
  91           = do_entry   env     e    >>= \ new_env ->
  92             do_entries new_env es
  93         -------
  94         do_entry env e
  95           = case (acceptable_hi (reverse e)) of
  96               Nothing  -> --trace ("Deemed uncool:"++e) $
  97                           return env
  98               Just mod ->
  99                 let
 100                       pmod = _PK_ mod
 101                 in
 102                 case (lookupFM env pmod) of
 103                   Nothing -> --trace ("Adding "++mod++" -> "++e) $
 104                              return (addToFM env pmod (dir ++ '/':e))
 105                              -- ToDo: use DIR_SEP, not /
 106
 107                   Just xx -> ( if de_dot xx /= e then trace ("Already mapped!! "++mod++" -> "++xx++"; ignoring:"++e) else id) $
 108                              return env
 109     -------
 110     acceptable_hi rev_e -- looking at pathname *backwards*
 111       = case (startsWith (reverse opt_HiSuffix) rev_e) of
 112           Nothing -> Nothing
 113           Just xs -> plausible_modname xs{-reversed-}
 114
 115     -------
 116     de_dot ('.' : '/' : xs) = xs
 117     de_dot xs               = xs
 118
 119     -------
 120     plausible_modname rev_e
 121       = let
 122             cand = reverse (takeWhile is_modname_char rev_e)
 123         in
 124         if null cand || not (isUpper (head cand))
 125         then Nothing
 126         else Just cand
 127       where
 128         is_modname_char c = isAlphanum c || c == '_'
 129 \end{code}
 130
 131 *********************************************************
 132 *                                                       *
 133 \subsection{Reading interface files}
 134 *                                                       *
 135 *********************************************************
 136
 137 Return cached info about a Module's interface; otherwise,
 138 read the interface (using our @ModuleToIfaceFilePath@ map
 139 to decide where to look).
 140
 141 \begin{code}
 142 cachedIface :: IfaceCache
 143             -> Module
 144             -> IO (MaybeErr ParsedIface Error)
 145
 146 cachedIface iface_cache mod
 147   = readVar iface_cache `thenPrimIO` \ (iface_fm, file_fm) ->
 148
 149     case (lookupFM iface_fm mod) of
 150       Just iface -> return (Succeeded iface)
 151       Nothing    ->
 152         case (lookupFM file_fm mod) of
 153           Nothing   -> return (Failed (noIfaceErr mod))
 154           Just file ->
 155             readIface file mod >>= \ read_iface ->
 156             case read_iface of
 157               Failed err      -> -- pprTrace "module-file map:\n" (ppAboves [ppCat [ppPStr m, ppStr f] | (m,f) <- fmToList file_fm]) $
 158                                  return (Failed err)
 159               Succeeded iface ->
 160                 let
 161                     iface_fm' = addToFM iface_fm mod iface
 162                 in
 163                 writeVar iface_cache (iface_fm', file_fm) `seqPrimIO`
 164                 return (Succeeded iface)
 165
 166 ----------
 167 cachedDecl :: IfaceCache
 168            -> Bool      -- True <=> tycon or class name
 169            -> RdrName
 170            -> IO (MaybeErr RdrIfaceDecl Error)
 171
 172 -- ToDo: this is where the check for Prelude.map being
 173 --       located in PreludeList.map should be done ...
 174
 175 cachedDecl iface_cache class_or_tycon orig
 176   = cachedIface iface_cache mod         >>= \ maybe_iface ->
 177     case maybe_iface of
 178       Failed err -> return (Failed err)
 179       Succeeded (ParsedIface _ _ _ _ exps _ _ tdefs vdefs _ _) ->
 180         case (lookupFM (if class_or_tycon then tdefs else vdefs) str) of
 181           Just decl -> return (Succeeded decl)
 182           Nothing   -> return (Failed (noDeclInIfaceErr mod str))
 183   where
 184     (mod, str) = moduleNamePair orig
 185
 186 ----------
 187 cachedDeclByType :: IfaceCache
 188                  -> RnName{-NB: diff type than cachedDecl -}
 189                  -> IO (MaybeErr RdrIfaceDecl Error)
 190
 191 cachedDeclByType iface_cache rn
 192     -- the idea is: check that, e.g., if we're given an
 193     -- RnClass, then we really get back a ClassDecl from
 194     -- the cache (not an RnData, or something silly)
 195   = cachedDecl iface_cache (isRnTyConOrClass rn) (origName rn)  >>= \ maybe_decl ->
 196     let
 197         return_maybe_decl = return maybe_decl
 198         return_failed msg = return (Failed msg)
 199     in
 200     case maybe_decl of
 201       Failed _ -> return_maybe_decl
 202       Succeeded if_decl ->
 203         case rn of
 204           WiredInId _       -> return_failed (ifaceLookupWiredErr "value" rn)
 205           WiredInTyCon _    -> return_failed (ifaceLookupWiredErr "type constructor" rn)
 206           RnUnbound _       -> pprPanic "cachedDeclByType:" (ppr PprDebug rn)
 207
 208           RnSyn _           -> return_maybe_decl
 209           RnData _ _ _      -> return_maybe_decl
 210           RnImplicitTyCon _ -> if is_tycon_decl if_decl
 211                                then return_maybe_decl
 212                                else return_failed (badIfaceLookupErr "type constructor" rn if_decl)
 213
 214           RnClass _ _       -> return_maybe_decl
 215           RnImplicitClass _ -> if is_class_decl if_decl
 216                                then return_maybe_decl
 217                                else return_failed (badIfaceLookupErr "class" rn if_decl)
 218
 219           RnName _          -> return_maybe_decl
 220           RnConstr _ _      -> return_maybe_decl
 221           RnField _ _       -> return_maybe_decl
 222           RnClassOp _ _     -> return_maybe_decl
 223           RnImplicit _      -> if is_val_decl if_decl
 224                                then return_maybe_decl
 225                                else return_failed (badIfaceLookupErr "value" rn if_decl)
 226   where
 227     is_tycon_decl (TypeSig _ _ _)       = True
 228     is_tycon_decl (NewTypeSig _ _ _ _)  = True
 229     is_tycon_decl (DataSig _ _ _ _ _)   = True
 230     is_tycon_decl _                     = False
 231
 232     is_class_decl (ClassSig _ _ _ _)    = True
 233     is_class_decl _                     = False
 234
 235     is_val_decl (ValSig _ _ _)          = True
 236     is_val_decl (DataSig _ _ _ _ _)     = True  -- may be a constr or field
 237     is_val_decl (NewTypeSig _ _ _ _)    = True  -- may be a constr
 238     is_val_decl (ClassSig _ _ _ _)      = True  -- may be a method
 239     is_val_decl _                       = False
 240 \end{code}
 241
 242 \begin{code}
 243 readIface :: FilePath -> Module
 244               -> IO (MaybeErr ParsedIface Error)
 245
 246 readIface file mod
 247   = readFile file   `thenPrimIO` \ read_result ->
 248     case read_result of
 249       Left  err      -> return (Failed (cannaeReadErr file err))
 250       Right contents -> return (parseIface contents)
 251 \end{code}
 252
 253
 254 \begin{code}
 255 rnIfaces :: IfaceCache                  -- iface cache (mutvar)
 256          -> [Module]                    -- directly imported modules
 257          -> UniqSupply
 258          -> RnEnv                       -- defined (in the source) name env
 259          -> RnEnv                       -- mentioned (in the source) name env
 260          -> RenamedHsModule             -- module to extend with iface decls
 261          -> [RnName]                    -- imported names required (really the
 262                                         -- same info as in mentioned name env)
 263                                         -- Also, all the things we may look up
 264                                         -- later by key (Unique).
 265          -> IO (RenamedHsModule,        -- extended module
 266                 RnEnv,                  -- final env (for renaming derivings)
 267                 ImplicitEnv,            -- implicit names used (for usage info)
 268                 (Bag Error, Bag Warning))
 269
 270 rnIfaces iface_cache imp_mods us
 271          def_env@((dqual, dunqual, dtc_qual, dtc_unqual), dstack)
 272          occ_env@((qual, unqual, tc_qual, tc_unqual), stack)
 273          rn_module@(HsModule modname iface_version exports imports fixities
 274                       typedecls typesigs classdecls instdecls instsigs
 275                       defdecls binds sigs src_loc)
 276          todo
 277   = {-
 278     pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $
 279
 280     pprTrace "rnIfaces:qual:"      (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM qual]) $
 281     pprTrace "rnIfaces:unqual:"    (ppCat (map ppPStr (keysFM unqual))) $
 282     pprTrace "rnIfaces:tc_qual:"   (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM tc_qual]) $
 283     pprTrace "rnIfaces:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
 284
 285     pprTrace "rnIfaces:dqual:"     (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM dqual]) $
 286     pprTrace "rnIfaces:dunqual:"   (ppCat (map ppPStr (keysFM dunqual))) $
 287     pprTrace "rnIfaces:dtc_qual:"  (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM dtc_qual]) $
 288     pprTrace "rnIfaces:dtc_unqual:"(ppCat (map ppPStr (keysFM dtc_unqual))) $
 289     -}
 290
 291     -- do transitive closure to bring in all needed names/defns and insts:
 292
 293     decls_and_insts todo def_env occ_env empty_return us
 294         >>= \ (((if_typedecls, if_classdecls, if_instdecls, if_sigs),
 295                 if_implicits,
 296                 if_errs_warns),
 297                if_final_env) ->
 298
 299     return (HsModule modname iface_version exports imports fixities
 300                  (typedecls ++ if_typedecls)
 301                  typesigs
 302                  (classdecls ++ if_classdecls)
 303                  (instdecls  ++ if_instdecls)
 304                  instsigs defdecls binds
 305                  (sigs ++ if_sigs)
 306                  src_loc,
 307             if_final_env,
 308             if_implicits,
 309             if_errs_warns)
 310   where
 311     decls_and_insts todo def_env occ_env to_return us
 312       = do_decls todo                    -- initial batch of names to process
 313                  (def_env, occ_env, us1) -- init stuff down
 314                  to_return               -- acc results
 315            >>= \ (decls_return,
 316                   decls_def_env,
 317                   decls_occ_env) ->
 318
 319         cacheInstModules iface_cache imp_mods >>= \ errs ->
 320
 321         do_insts decls_def_env decls_occ_env emptyRnEnv emptyFM
 322                  (add_errs errs decls_return) us2
 323       where
 324         (us1,us2) = splitUniqSupply us
 325
 326     do_insts def_env occ_env prev_env done_insts to_return us
 327       | size_tc_env occ_env == size_tc_env prev_env
 328       = return (to_return, occ_env)
 329
 330       | otherwise
 331       = rnIfaceInstStuff iface_cache modname us1 occ_env done_insts to_return
 332            >>= \ (insts_return,
 333                   new_insts,
 334                   insts_occ_env,
 335                   new_unknowns) ->
 336
 337         do_decls new_unknowns                   -- new batch of names to process
 338                  (def_env, insts_occ_env, us2)  -- init stuff down
 339                  insts_return                   -- acc results
 340            >>= \ (decls_return,
 341                   decls_def_env,
 342                   decls_occ_env) ->
 343
 344         do_insts decls_def_env decls_occ_env occ_env new_insts decls_return us3
 345       where
 346         (us1,us') = splitUniqSupply us
 347         (us2,us3) = splitUniqSupply us'
 348
 349         size_tc_env ((_, _, qual, unqual), _)
 350           = sizeFM qual + sizeFM unqual
 351
 352
 353     do_decls :: [RnName]        -- Names we're looking for; we keep adding/deleting
 354                                 -- from this list; we're done when empty (nothing
 355                                 -- more needs to be looked for)
 356              -> Go_Down         -- see defn below
 357              -> To_Return       -- accumulated result
 358              -> IO (To_Return,
 359                     RnEnv,      -- extended decl env
 360                     RnEnv)      -- extended occ env
 361
 362     do_decls to_find@[] down to_return
 363       = return (to_return, defenv down, occenv down)
 364
 365     do_decls to_find@(n:ns) down to_return
 366       = case (lookup_defd down n) of
 367           Just  _ -> -- previous processing must've found the stuff for this name;
 368                      -- continue with the rest:
 369                      -- pprTrace "do_decls:done:" (ppr PprDebug n) $
 370                      do_decls ns down to_return
 371
 372           Nothing -> -- OK, see what the cache has for us...
 373
 374             cachedDeclByType iface_cache n >>= \ maybe_ans ->
 375             case maybe_ans of
 376               Failed err -> -- add the error, but keep going:
 377                             -- pprTrace "do_decls:cache error:" (ppr PprDebug n) $
 378                             do_decls ns down (add_err err to_return)
 379
 380               Succeeded iface_decl -> -- something needing renaming!
 381                 let
 382                     (us1, us2) = splitUniqSupply (uniqsupply down)
 383                 in
 384                 case (initRn False{-iface-} modname (occenv down) us1 (
 385                         setExtraRn emptyUFM{-no fixities-} $
 386                         rnIfaceDecl iface_decl)) of {
 387                   ((if_decl, if_defd, if_implicits), if_errs, if_warns) ->
 388                     let
 389                         new_unknowns = eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits)
 390                     in
 391                     {-
 392                     pprTrace "do_decls:renamed:" (ppAboves [ppr PprDebug n
 393                         , ppCat [ppStr "new unknowns:", interpp'SP PprDebug new_unknowns]
 394                         , ppCat [ppStr "defd vals:", interpp'SP PprDebug [n | (_,n) <- fst if_defd] ]
 395                         , ppCat [ppStr "defd  tcs:", interpp'SP PprDebug [n | (_,n) <- snd if_defd] ]
 396                         ]) $
 397                     -}
 398                     do_decls (new_unknowns ++ ns)
 399                              (add_occs       if_defd if_implicits $
 400                                new_uniqsupply us2 down)
 401                              (add_decl       if_decl            $
 402                                add_implicits if_implicits       $
 403                                 add_errs     if_errs            $
 404                                  add_warns   if_warns to_return)
 405                 }
 406
 407 -----------
 408 type Go_Down   = (RnEnv,        -- stuff we already have defns for;
 409                                 -- to check quickly if we've already
 410                                 -- found something for the name under consideration,
 411                                 -- due to previous processing.
 412                                 -- It starts off just w/ the defns for
 413                                 -- the things in this module.
 414                   RnEnv,        -- occurrence env; this gets added to as
 415                                 -- we process new iface decls.  It includes
 416                                 -- entries for *all* occurrences, including those
 417                                 -- for which we have definitions.
 418                   UniqSupply    -- the obvious
 419                  )
 420
 421 lookup_defd (def_env, _, _) n
 422   | isRnTyConOrClass n
 423   = lookupTcRnEnv def_env (origName n)
 424   | otherwise
 425   = lookupRnEnv def_env (origName n)
 426
 427 defenv     (def_env, _, _) = def_env
 428 occenv     (_, occ_env, _) = occ_env
 429 uniqsupply (_, _,      us) = us
 430
 431 new_uniqsupply us (def_env, occ_env, _) = (def_env, occ_env, us)
 432
 433 add_occs (val_defds, tc_defds) (val_imps, tc_imps) (def_env, occ_env, us)
 434   = case (extendGlobalRnEnv def_env val_defds tc_defds) of { (new_def_env, def_dups) ->
 435     ASSERT(isEmptyBag def_dups)
 436     let
 437         val_occs = val_defds ++ fmToList val_imps
 438         tc_occs  = tc_defds  ++ fmToList tc_imps
 439     in
 440     case (extendGlobalRnEnv occ_env val_occs tc_occs)   of { (new_occ_env, occ_dups) ->
 441
 442 --  ASSERT(isEmptyBag occ_dups)
 443 --  False because we may get a dup on the name we just shoved in
 444
 445     (new_def_env, new_occ_env, us) }}
 446
 447 ----------------
 448 type To_Return = (([RenamedTyDecl], [RenamedClassDecl], [RenamedInstDecl], [RenamedSig]),
 449                   ImplicitEnv,  -- new names used implicitly
 450                   (Bag Error, Bag Warning)
 451                  )
 452
 453 empty_return :: To_Return
 454 empty_return = (([],[],[],[]), emptyImplicitEnv, (emptyBag,emptyBag))
 455
 456 add_decl decl ((tydecls, classdecls, instdecls, sigs), implicit, msgs)
 457   = case decl of
 458       AddedTy    t -> ((t:tydecls, classdecls, instdecls, sigs), implicit, msgs)
 459       AddedClass c -> ((tydecls, c:classdecls, instdecls, sigs), implicit, msgs)
 460       AddedSig   s -> ((tydecls, classdecls, instdecls, s:sigs), implicit, msgs)
 461
 462 add_insts is ((tydecls, classdecls, instdecls, sigs), implicit, msgs)
 463   = ((tydecls, classdecls, is ++ instdecls, sigs), implicit, msgs)
 464
 465 add_implicits (val_imps, tc_imps) (decls, (val_fm, tc_fm), msgs)
 466   = (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM`  tc_imps), msgs)
 467
 468 add_err  err (decls,implicit,(errs,warns)) = (decls,implicit,(errs `snocBag`   err,warns))
 469 add_errs ers (decls,implicit,(errs,warns)) = (decls,implicit,(errs `unionBags` ers,warns))
 470 add_warns ws (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `unionBags` ws))
 471 \end{code}
 472
 473 \begin{code}
 474 data AddedDecl -- purely local
 475   = AddedTy     RenamedTyDecl
 476   | AddedClass  RenamedClassDecl
 477   | AddedSig    RenamedSig
 478
 479 rnIfaceDecl :: RdrIfaceDecl
 480             -> RnM_Fixes _RealWorld
 481                    (AddedDecl,  -- the resulting decl to add to the pot
 482                     ([(RdrName,RnName)], [(RdrName,RnName)]),
 483                                 -- new val/tycon-class names that have
 484                                 -- *been defined* while processing this decl
 485                     ImplicitEnv -- new implicit val/tycon-class names that we
 486                                 -- stumbled into
 487                    )
 488
 489 rnIfaceDecl (TypeSig tc _ decl)
 490   = rnTyDecl    decl    `thenRn` \ rn_decl   ->
 491     lookupTyCon tc      `thenRn` \ rn_tc     ->
 492     getImplicitUpRn     `thenRn` \ mentioned ->
 493     let
 494         defds = ([], [(tc, rn_tc)])
 495         implicits = mentioned `sub` defds
 496     in
 497     returnRn (AddedTy rn_decl, defds, implicits)
 498
 499 rnIfaceDecl (NewTypeSig tc dc _ decl)
 500   = rnTyDecl    decl    `thenRn` \ rn_decl   ->
 501     lookupTyCon tc      `thenRn` \ rn_tc     ->
 502     lookupValue dc      `thenRn` \ rn_dc     ->
 503     getImplicitUpRn     `thenRn` \ mentioned ->
 504     let
 505         defds = ([(dc, rn_dc)], [(tc, rn_tc)])
 506         implicits = mentioned `sub` defds
 507     in
 508     returnRn (AddedTy rn_decl, defds, implicits)
 509
 510 rnIfaceDecl (DataSig tc dcs fcs _ decl)
 511   = rnTyDecl    decl            `thenRn` \ rn_decl   ->
 512     lookupTyCon tc              `thenRn` \ rn_tc     ->
 513     mapRn lookupValue dcs       `thenRn` \ rn_dcs    ->
 514     mapRn lookupValue fcs       `thenRn` \ rn_fcs    ->
 515     getImplicitUpRn             `thenRn` \ mentioned ->
 516     let
 517         defds = (zip dcs rn_dcs ++ zip fcs rn_fcs , [(tc, rn_tc)])
 518         implicits = mentioned `sub` defds
 519     in
 520     returnRn (AddedTy rn_decl, defds, implicits)
 521
 522 rnIfaceDecl (ClassSig clas ops _ decl)
 523   = rnClassDecl decl                    `thenRn` \ rn_decl   ->
 524     lookupClass clas                    `thenRn` \ rn_clas   ->
 525     mapRn (lookupClassOp rn_clas) ops   `thenRn` \ rn_ops    ->
 526     getImplicitUpRn                     `thenRn` \ mentioned ->
 527     let
 528         defds = (ops `zip` rn_ops, [(clas, rn_clas)])
 529         implicits = mentioned `sub` defds
 530     in
 531     returnRn (AddedClass rn_decl, defds, implicits)
 532
 533 rnIfaceDecl (ValSig f src_loc ty)
 534     -- should rename_sig in RnBinds be used here? ToDo
 535   = lookupValue f                       `thenRn` \ rn_f  ->
 536     -- pprTrace "rnIfaceDecl:ValSig:" (ppr PprDebug ty) $
 537     rnPolyType nullTyVarNamesEnv ty     `thenRn` \ rn_ty ->
 538     getImplicitUpRn                     `thenRn` \ mentioned ->
 539     let
 540         defds = ([(f, rn_f)], [])
 541         implicits = mentioned `sub` defds
 542     in
 543     returnRn (AddedSig (Sig rn_f rn_ty noGenPragmas src_loc), defds, implicits)
 544
 545 ----
 546 sub :: ImplicitEnv -> ([(RdrName,RnName)], [(RdrName,RnName)]) -> ImplicitEnv
 547
 548 sub (val_ment, tc_ment) (val_defds, tc_defds)
 549   = (delListFromFM val_ment (map fst val_defds),
 550      delListFromFM tc_ment  (map fst tc_defds))
 551 \end{code}
 552
 553 % ------------------------------
 554
 555 @cacheInstModules@: cache instance modules specified in imports
 556
 557 \begin{code}
 558 cacheInstModules :: IfaceCache -> [Module] -> IO (Bag Error)
 559 cacheInstModules iface_cache imp_mods
 560   = readVar iface_cache         `thenPrimIO` \ (iface_fm, _) ->
 561     let
 562         imp_ifaces      = [ iface | Just iface <- map (lookupFM iface_fm) imp_mods ]
 563         (imp_imods, _)  = removeDups cmpPString (bagToList (unionManyBags (map get_ims imp_ifaces)))
 564         get_ims (ParsedIface _ _ _ _ _ ims _ _ _ _ _) = ims
 565     in
 566     accumulate (map (cachedIface iface_cache) imp_imods) >>= \ err_or_ifaces ->
 567
 568     -- Sanity Check:
 569     -- Assert that instance modules given by direct imports contains
 570     -- instance modules extracted from all visited modules
 571
 572     readVar iface_cache         `thenPrimIO` \ (all_iface_fm, _) ->
 573     let
 574         all_ifaces     = eltsFM all_iface_fm
 575         (all_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims (all_ifaces))))
 576     in
 577     ASSERT(sortLt (<) imp_imods == sortLt (<) all_imods)
 578
 579     return (bag_errs err_or_ifaces)
 580   where
 581     bag_errs [] = emptyBag
 582     bag_errs (Failed err :rest) = err `consBag` bag_errs rest
 583     bag_errs (Succeeded _:rest) = bag_errs rest
 584 \end{code}
 585
 586
 587 @rnIfaceInstStuff@: Deal with instance declarations from interface files.
 588
 589 \begin{code}
 590 type InstanceEnv = FiniteMap (RdrName, RdrName) Int
 591
 592 rnIfaceInstStuff
 593         :: IfaceCache           -- all about ifaces we've read
 594         -> Module
 595         -> UniqSupply
 596         -> RnEnv                -- current occ env
 597         -> InstanceEnv          -- instances for these tycon/class pairs done
 598         -> To_Return
 599         -> IO (To_Return,
 600                InstanceEnv,     -- extended instance env
 601                RnEnv,           -- final occ env
 602                [RnName])        -- new unknown names
 603
 604 rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return
 605   = -- all the instance decls we might even want to consider
 606     -- are in the ParsedIfaces that are in our cache
 607
 608     readVar iface_cache `thenPrimIO` \ (iface_fm, _) ->
 609     let
 610         all_ifaces        = eltsFM iface_fm
 611         all_insts         = unionManyBags (map get_insts all_ifaces)
 612         interesting_insts = filter want_inst (bagToList all_insts)
 613
 614         -- Sanity Check:
 615         -- Assert that there are no more instances for the done instances
 616
 617         claim_done       = filter is_done_inst (bagToList all_insts)
 618         claim_done_env   = foldr add_done_inst emptyFM claim_done
 619         has_val fm (k,i) = case lookupFM fm k of { Nothing -> False; Just v -> i == v }
 620     in
 621     {-
 622       pprTrace "all_insts:\n"         (ppr_insts (bagToList all_insts)) $
 623       pprTrace "interesting_insts:\n" (ppr_insts interesting_insts) $
 624     -}
 625     ASSERT(sizeFM done_inst_env == sizeFM claim_done_env)
 626     ASSERT(all (has_val claim_done_env) (fmToList done_inst_env))
 627
 628     case (initRn False{-iface-} modname occ_env us (
 629             setExtraRn emptyUFM{-no fixities-}  $
 630             mapRn rnIfaceInst interesting_insts `thenRn` \ insts ->
 631             getImplicitUpRn                     `thenRn` \ implicits ->
 632             returnRn (insts, implicits))) of {
 633       ((if_insts, if_implicits), if_errs, if_warns) ->
 634
 635         return (add_insts      if_insts         $
 636                  add_implicits if_implicits     $
 637                   add_errs     if_errs          $
 638                    add_warns   if_warns to_return,
 639                 foldr add_done_inst done_inst_env interesting_insts,
 640                 add_imp_occs if_implicits occ_env,
 641                 eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits))
 642     }
 643   where
 644     get_insts (ParsedIface _ _ _ _ _ _ _ _ _ insts _) = insts
 645
 646     add_done_inst (InstSig clas tycon _ _) inst_env
 647       = addToFM_C (+) inst_env (tycon,clas) 1
 648
 649     is_done_inst (InstSig clas tycon _ _)
 650       = maybeToBool (lookupFM done_inst_env (tycon,clas))
 651
 652     add_imp_occs (val_imps, tc_imps) occ_env
 653       = case extendGlobalRnEnv occ_env (fmToList val_imps) (fmToList tc_imps) of
 654           (ext_occ_env, occ_dups) -> ASSERT(isEmptyBag occ_dups)
 655                                      ext_occ_env
 656
 657     want_inst i@(InstSig clas tycon _ _)
 658       = -- it's a "good instance" (one to hang onto) if we have a
 659         -- chance of referring to *both* the class and tycon later on ...
 660
 661         mentionable tycon && mentionable clas && not (is_done_inst i)
 662       where
 663         mentionable nm
 664           = case lookupTcRnEnv occ_env nm of
 665               Just  _ -> True
 666               Nothing -> -- maybe it's builtin
 667                 case nm of
 668                   Qual _ _ -> False
 669                   Unqual n ->
 670                     case (lookupFM b_tc_names n) of
 671                       Just  _ -> True
 672                       Nothing -> maybeToBool (lookupFM b_keys n)
 673
 674     (b_tc_names, b_keys) -- pretty UGLY ...
 675       = case builtinNameInfo of ((_,builtin_tcs),b_keys,_) -> (builtin_tcs,b_keys)
 676
 677     ppr_insts insts
 678       = ppAboves (map ppr_inst insts)
 679       where
 680         ppr_inst (InstSig c t _ inst_decl)
 681           = ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug inst_decl]
 682 \end{code}
 683
 684 \begin{code}
 685 rnIfaceInst :: RdrIfaceInst -> RnM_Fixes _RealWorld RenamedInstDecl
 686
 687 rnIfaceInst (InstSig _ _ _ inst_decl) = rnInstDecl inst_decl
 688 \end{code}
 689
 690 \begin{code}
 691 finalIfaceInfo ::
 692            IfaceCache                   -- iface cache
 693         -> [RnName]                     -- all imported names required
 694         -> [Module]                     -- directly imported modules
 695         -> IO (VersionInfo,             -- info about version numbers
 696                [Module])                -- special instance modules
 697
 698 type VersionInfo = [(Module, Version, [(FAST_STRING, Version)])]
 699
 700 finalIfaceInfo iface_cache imps_reqd imp_mods
 701   = return ([], [])
 702 \end{code}
 703
 704
 705 \begin{code}
 706 noIfaceErr mod sty
 707   = ppCat [ppPStr SLIT("Could not find interface for:"), ppPStr mod]
 708
 709 noDeclInIfaceErr mod str sty
 710   = ppBesides [ppPStr SLIT("Could not find interface declaration of: "),
 711                ppPStr mod, ppStr ".", ppPStr str]
 712
 713 cannaeReadErr file err sty
 714   = ppBesides [ppPStr SLIT("Failed in reading file: "), ppStr file, ppStr "; error=", ppStr (show err)]
 715
 716 ifaceLookupWiredErr msg n sty
 717   = ppBesides [ppPStr SLIT("Why am I looking up a wired-in "), ppStr msg, ppChar ':', ppr sty n]
 718
 719 badIfaceLookupErr msg name decl sty
 720   = ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppPStr SLIT(" declaration, but got this: ???")]
 721 \end{code}