LoadIface.lhs 33.8 KB
Newer Older
Simon Marlow's avatar
Simon Marlow committed
1 2
%
% (c) The University of Glasgow 2006
3 4
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
Simon Marlow's avatar
Simon Marlow committed
5 6

Loading interface files
7 8 9

\begin{code}
module LoadIface (
10 11 12 13 14
        -- RnM/TcM functions
        loadModuleInterface, loadModuleInterfaces, 
        loadSrcInterface, loadInterfaceForName, 

        -- IfM functions
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
15 16 17 18 19
        loadInterface, loadWiredInHomeIface, 
        loadSysInterface, loadUserInterface, 
        findAndReadIface, readIface,    -- Used when reading the module's old interface
        loadDecls,      -- Should move to TcIface and be renamed
        initExternalPackageState,
20

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
21
        ifaceStats, pprModIface, showIface
22 23 24 25
   ) where

#include "HsVersions.h"

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
26 27
import {-# SOURCE #-}   TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst, 
                                 tcIfaceFamInst, tcIfaceVectInfo, tcIfaceAnnotations )
28

Simon Marlow's avatar
Simon Marlow committed
29
import DynFlags
30
import IfaceSyn
Simon Marlow's avatar
Simon Marlow committed
31 32 33 34
import IfaceEnv
import HscTypes

import BasicTypes hiding (SuccessFlag(..))
35
import TcRnMonad
Simon Marlow's avatar
Simon Marlow committed
36 37 38

import PrelNames
import PrelInfo
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
39
import MkId     ( seqId )
Simon Marlow's avatar
Simon Marlow committed
40
import Rules
41
import Annotations
Simon Marlow's avatar
Simon Marlow committed
42 43 44
import InstEnv
import FamInstEnv
import Name
45
import NameEnv
46
import Avail
Simon Marlow's avatar
Simon Marlow committed
47
import Module
Simon Marlow's avatar
Simon Marlow committed
48 49 50
import Maybes
import ErrUtils
import Finder
51
import UniqFM
Simon Marlow's avatar
Simon Marlow committed
52
import StaticFlags
53
import Outputable
Simon Marlow's avatar
Simon Marlow committed
54 55
import BinIface
import Panic
Ian Lynagh's avatar
Ian Lynagh committed
56
import Util
57
import FastString
58
import Fingerprint
Simon Marlow's avatar
Simon Marlow committed
59

Ian Lynagh's avatar
Ian Lynagh committed
60
import Control.Monad
61 62 63 64
\end{code}


%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
65
%*                                                                      *
66
        loadSrcInterface, loadOrphanModules, loadInterfaceForName
67

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
68 69
                These three are called from TcM-land    
%*                                                                      *
70 71 72
%************************************************************************

\begin{code}
Simon Marlow's avatar
Simon Marlow committed
73 74
-- | Load the interface corresponding to an @import@ directive in 
-- source code.  On a failure, fail in the monad with an error message.
75 76 77 78 79 80 81
loadSrcInterface :: SDoc
                 -> ModuleName
                 -> IsBootInterface     -- {-# SOURCE #-} ?
                 -> Maybe FastString    -- "package", if any
                 -> RnM ModIface

loadSrcInterface doc mod want_boot maybe_pkg  = do
Simon Marlow's avatar
Simon Marlow committed
82 83 84 85 86 87
  -- We must first find which Module this import refers to.  This involves
  -- calling the Finder, which as a side effect will search the filesystem
  -- and create a ModLocation.  If successful, loadIface will read the
  -- interface; it will call the Finder again, but the ModLocation will be
  -- cached from the first search.
  hsc_env <- getTopEnv
88
  res <- liftIO $ findImportedModule hsc_env mod maybe_pkg
Simon Marlow's avatar
Simon Marlow committed
89 90 91 92
  case res of
    Found _ mod -> do
      mb_iface <- initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)
      case mb_iface of
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
93 94
        Failed err      -> failWithTc err
        Succeeded iface -> return iface
Simon Marlow's avatar
Simon Marlow committed
95 96
    err ->
        let dflags = hsc_dflags hsc_env in
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
97
        failWithTc (cannotFindInterface dflags mod err)
98

99 100 101 102 103 104 105
-- | Load interface for a module.
loadModuleInterface :: SDoc -> Module -> TcM ModIface
loadModuleInterface doc mod = initIfaceTcRn (loadSysInterface doc mod)

-- | Load interfaces for a collection of modules.
loadModuleInterfaces :: SDoc -> [Module] -> TcM ()
loadModuleInterfaces doc mods
106
  | null mods = return ()
107
  | otherwise = initIfaceTcRn (mapM_ load mods)
108
  where
109
    load mod = loadSysInterface (doc <+> parens (ppr mod)) mod
110

Simon Marlow's avatar
Simon Marlow committed
111 112 113
-- | Loads the interface for a given Name.
loadInterfaceForName :: SDoc -> Name -> TcRn ModIface
loadInterfaceForName doc name
Ian Lynagh's avatar
Ian Lynagh committed
114 115 116 117 118 119
  = do { 
    when debugIsOn $ do
        -- Should not be called with a name from the module being compiled
        { this_mod <- getModule
        ; MASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc )
        }
120 121
  ; ASSERT2( isExternalName name, ppr name ) 
    initIfaceTcRn $ loadSysInterface doc (nameModule name)
Ian Lynagh's avatar
Ian Lynagh committed
122
  }
123 124 125 126
\end{code}


%*********************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
127 128
%*                                                      *
                loadInterface
129

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
130 131 132 133
        The main function to load an interface
        for an imported module, and put it in
        the External Package State
%*                                                      *
134
%*********************************************************
135

136
\begin{code}
Simon Marlow's avatar
Simon Marlow committed
137
-- | An 'IfM' function to load the home interface for a wired-in thing,
138
-- so that we're sure that we see its instance declarations and rules
139
-- See Note [Loading instances for wired-in things] in TcIface
Simon Marlow's avatar
Simon Marlow committed
140
loadWiredInHomeIface :: Name -> IfM lcl ()
141 142
loadWiredInHomeIface name
  = ASSERT( isWiredInName name )
143
    do _ <- loadSysInterface doc (nameModule name); return ()
144
  where
Ian Lynagh's avatar
Ian Lynagh committed
145
    doc = ptext (sLit "Need home interface for wired-in thing") <+> ppr name
146

147
------------------
148
-- | Loads a system interface and throws an exception if it fails
149
loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
150 151
loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBySystem

152
------------------
153 154 155
-- | Loads a user interface and throws an exception if it fails. The first parameter indicates
-- whether we should import the boot variant of the module
loadUserInterface :: Bool -> SDoc -> Module -> IfM lcl ModIface
156 157
loadUserInterface is_boot doc mod_name 
  = loadInterfaceWithException doc mod_name (ImportByUser is_boot)
158

159
------------------
160 161 162
-- | A wrapper for 'loadInterface' that throws an exception if it fails
loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface
loadInterfaceWithException doc mod_name where_from
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
163 164 165 166
  = do  { mb_iface <- loadInterface doc mod_name where_from
        ; case mb_iface of 
            Failed err      -> ghcError (ProgramError (showSDoc err))
            Succeeded iface -> return iface }
167

168
------------------
Simon Marlow's avatar
Simon Marlow committed
169
loadInterface :: SDoc -> Module -> WhereFrom
170
              -> IfM lcl (MaybeErr MsgDoc ModIface)
171

172 173 174
-- loadInterface looks in both the HPT and PIT for the required interface
-- If not found, it loads it, and puts it in the PIT (always). 

175
-- If it can't find a suitable interface file, we
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
176 177 178
--      a) modify the PackageIfaceTable to have an empty entry
--              (to avoid repeated complaints)
--      b) return (Left message)
179 180 181
--
-- It's not necessarily an error for there not to be an interface
-- file -- perhaps the module has changed, and that interface 
182
-- is no longer used
183

184
loadInterface doc_str mod from
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
185 186 187 188 189 190
  = do  {       -- Read the state
          (eps,hpt) <- getEpsAndHpt

        ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from)

                -- Check whether we have the interface already
191
        ; dflags <- getDynFlags
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
192 193 194 195 196 197 198 199 200 201
        ; case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of {
            Just iface 
                -> return (Succeeded iface) ;   -- Already loaded
                        -- The (src_imp == mi_boot iface) test checks that the already-loaded
                        -- interface isn't a boot iface.  This can conceivably happen,
                        -- if an earlier import had a before we got to real imports.   I think.
            _ -> do {

        -- READ THE MODULE IN
        ; read_result <- case (wantHiBootFile dflags eps mod from) of
202 203
                           Failed err             -> return (Failed err)
                           Succeeded hi_boot_file -> findAndReadIface doc_str mod hi_boot_file
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238
        ; case read_result of {
            Failed err -> do
                { let fake_iface = emptyModIface mod

                ; updateEps_ $ \eps ->
                        eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface }
                        -- Not found, so add an empty iface to 
                        -- the EPS map so that we don't look again
                                
                ; return (Failed err) } ;

        -- Found and parsed!
        -- We used to have a sanity check here that looked for:
        --  * System importing ..
        --  * a home package module ..
        --  * that we know nothing about (mb_dep == Nothing)!
        --
        -- But this is no longer valid because thNameToGhcName allows users to
        -- cause the system to load arbitrary interfaces (by supplying an appropriate
        -- Template Haskell original-name).
            Succeeded (iface, file_path) ->

        let 
            loc_doc = text file_path
        in 
        initIfaceLcl mod loc_doc $ do

        --      Load the new ModIface into the External Package State
        -- Even home-package interfaces loaded by loadInterface 
        --      (which only happens in OneShot mode; in Batch/Interactive 
        --      mode, home-package modules are loaded one by one into the HPT)
        -- are put in the EPS.
        --
        -- The main thing is to add the ModIface to the PIT, but
        -- we also take the
239
        --      IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules, IfaceVectInfo
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
240 241 242 243 244 245 246 247 248 249 250 251 252
        -- out of the ModIface and put them into the big EPS pools

        -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined
        ---    names is done correctly (notably, whether this is an .hi file or .hi-boot file).
        --     If we do loadExport first the wrong info gets into the cache (unless we
        --      explicitly tag each export which seems a bit of a bore)

        ; ignore_prags      <- doptM Opt_IgnoreInterfacePragmas
        ; new_eps_decls     <- loadDecls ignore_prags (mi_decls iface)
        ; new_eps_insts     <- mapM tcIfaceInst (mi_insts iface)
        ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
        ; new_eps_rules     <- tcIfaceRules ignore_prags (mi_rules iface)
        ; new_eps_anns      <- tcIfaceAnnotations (mi_anns iface)
253
        ; new_eps_vect_info <- tcIfaceVectInfo mod (mkNameEnv new_eps_decls) (mi_vect_info iface)
254

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
255 256 257 258 259 260
        ; let { final_iface = iface {   
                                mi_decls     = panic "No mi_decls in PIT",
                                mi_insts     = panic "No mi_insts in PIT",
                                mi_fam_insts = panic "No mi_fam_insts in PIT",
                                mi_rules     = panic "No mi_rules in PIT",
                                mi_anns      = panic "No mi_anns in PIT"
261 262
                              }
               }
263

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
264
        ; updateEps_  $ \ eps -> 
265
           if elemModuleEnv mod (eps_PIT eps) then eps else
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
266 267 268 269 270 271 272 273 274
            eps { 
              eps_PIT          = extendModuleEnv (eps_PIT eps) mod final_iface,
              eps_PTE          = addDeclsToPTE   (eps_PTE eps) new_eps_decls,
              eps_rule_base    = extendRuleBaseList (eps_rule_base eps) 
                                                    new_eps_rules,
              eps_inst_env     = extendInstEnvList (eps_inst_env eps)  
                                                   new_eps_insts,
              eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps)
                                                      new_eps_fam_insts,
275 276
              eps_vect_info    = plusVectInfo (eps_vect_info eps) 
                                              new_eps_vect_info,
277 278
              eps_ann_env      = extendAnnEnvList (eps_ann_env eps)
                                                  new_eps_anns,
279
              eps_mod_fam_inst_env
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
280 281 282 283 284 285 286 287 288 289 290 291 292 293
                               = let
                                   fam_inst_env = 
                                     extendFamInstEnvList emptyFamInstEnv
                                                          new_eps_fam_insts
                                 in
                                 extendModuleEnv (eps_mod_fam_inst_env eps)
                                                 mod
                                                 fam_inst_env,
              eps_stats        = addEpsInStats (eps_stats eps) 
                                               (length new_eps_decls)
                                               (length new_eps_insts)
                                               (length new_eps_rules) }

        ; return (Succeeded final_iface)
294 295
    }}}}

296
wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom
297
               -> MaybeErr MsgDoc IsBootInterface
298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313
-- Figure out whether we want Foo.hi or Foo.hi-boot
wantHiBootFile dflags eps mod from
  = case from of
       ImportByUser usr_boot 
          | usr_boot && not this_package
          -> Failed (badSourceImport mod)
          | otherwise -> Succeeded usr_boot

       ImportBySystem
          | not this_package   -- If the module to be imported is not from this package
          -> Succeeded False   -- don't look it up in eps_is_boot, because that is keyed
                               -- on the ModuleName of *home-package* modules only. 
                               -- We never import boot modules from other packages!

          | otherwise
          -> case lookupUFM (eps_is_boot eps) (moduleName mod) of
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
314 315 316 317
                Just (_, is_boot) -> Succeeded is_boot
                Nothing           -> Succeeded False
                     -- The boot-ness of the requested interface, 
                     -- based on the dependencies in directly-imported modules
318 319 320 321 322 323 324 325 326 327
  where
    this_package = thisPackage dflags == modulePackageId mod

badSourceImport :: Module -> SDoc
badSourceImport mod
  = hang (ptext (sLit "You cannot {-# SOURCE #-} import a module from another package"))
       2 (ptext (sLit "but") <+> quotes (ppr mod) <+> ptext (sLit "is from package")
          <+> quotes (ppr (modulePackageId mod)))
\end{code}

328 329 330 331
{-
Used to be used for the loadInterface sanity check on system imports. That has been removed, but I'm leaving this in pending
review of this decision by SPJ - MCB 10/2008

Ian Lynagh's avatar
Ian Lynagh committed
332
badDepMsg :: Module -> SDoc
333
badDepMsg mod 
Ian Lynagh's avatar
Ian Lynagh committed
334 335
  = hang (ptext (sLit "Interface file inconsistency:"))
       2 (sep [ptext (sLit "home-package module") <+> quotes (ppr mod) <+> ptext (sLit "is needed,"), 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
336
               ptext (sLit "but is not listed in the dependencies of the interfaces directly imported by the module being compiled")])
337
-}
338

339
\begin{code}
340
-----------------------------------------------------
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
341
--      Loading type/class/value decls
342 343 344 345 346
-- We pass the full Module name here, replete with
-- its package info, so that we can build a Name for
-- each binder with the right package info in it
-- All subsequent lookups, including crucially lookups during typechecking
-- the declaration itself, will find the fully-glorious Name
347 348 349 350
--
-- We handle ATs specially.  They are not main declarations, but also not
-- implict things (in particular, adding them to `implicitTyThings' would mess
-- things up in the renaming/type checking of source programs).
351 352
-----------------------------------------------------

353 354 355 356
addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv
addDeclsToPTE pte things = extendNameEnvList pte things

loadDecls :: Bool
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
357 358
          -> [(Fingerprint, IfaceDecl)]
          -> IfL [(Name,TyThing)]
359 360
loadDecls ignore_prags ver_decls
   = do { mod <- getIfModule
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
361 362 363 364 365 366 367 368 369
        ; thingss <- mapM (loadDecl ignore_prags mod) ver_decls
        ; return (concat thingss)
        }

loadDecl :: Bool                    -- Don't load pragmas into the decl pool
         -> Module
          -> (Fingerprint, IfaceDecl)
          -> IfL [(Name,TyThing)]   -- The list can be poked eagerly, but the
                                    -- TyThings are forkM'd thunks
370
loadDecl ignore_prags mod (_version, decl)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
371 372 373
  = do  {       -- Populate the name cache with final versions of all 
                -- the names associated with the decl
          main_name      <- lookupOrig mod (ifName decl)
374
--        ; traceIf (text "Loading decl for " <> ppr main_name)
375

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
376 377 378 379 380 381
        -- Typecheck the thing, lazily
        -- NB. Firstly, the laziness is there in case we never need the
        -- declaration (in one-shot mode), and secondly it is there so that 
        -- we don't look up the occurrence of a name before calling mk_new_bndr
        -- on the binder.  This is important because we must get the right name
        -- which includes its nameParent.
382

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
383 384
        ; thing <- forkM doc $ do { bumpDeclStats main_name
                                  ; tcIfaceDecl ignore_prags decl }
385

386 387 388 389 390 391 392 393 394
        -- Populate the type environment with the implicitTyThings too.
        -- 
        -- Note [Tricky iface loop]
        -- ~~~~~~~~~~~~~~~~~~~~~~~~
        -- Summary: The delicate point here is that 'mini-env' must be
        -- buildable from 'thing' without demanding any of the things
        -- 'forkM'd by tcIfaceDecl.
        --
        -- In more detail: Consider the example
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
395
        --      data T a = MkT { x :: T a }
396 397 398 399
        -- The implicitTyThings of T are:  [ <datacon MkT>, <selector x>]
        -- (plus their workers, wrappers, coercions etc etc)
        -- 
        -- We want to return an environment 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
400
        --      [ "MkT" -> <datacon MkT>, "x" -> <selector x>, ... ]
401 402 403
        -- (where the "MkT" is the *Name* associated with MkT, etc.)
        --
        -- We do this by mapping the implict_names to the associated
404
        -- TyThings.  By the invariant on ifaceDeclImplicitBndrs and
405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439
        -- implicitTyThings, we can use getOccName on the implicit
        -- TyThings to make this association: each Name's OccName should
        -- be the OccName of exactly one implictTyThing.  So the key is
        -- to define a "mini-env"
        --
        -- [ 'MkT' -> <datacon MkT>, 'x' -> <selector x>, ... ]
        -- where the 'MkT' here is the *OccName* associated with MkT.
        --
        -- However, there is a subtlety: due to how type checking needs
        -- to be staged, we can't poke on the forkM'd thunks inside the
        -- implictTyThings while building this mini-env.  
        -- If we poke these thunks too early, two problems could happen:
        --    (1) When processing mutually recursive modules across
        --        hs-boot boundaries, poking too early will do the
        --        type-checking before the recursive knot has been tied,
        --        so things will be type-checked in the wrong
        --        environment, and necessary variables won't be in
        --        scope.
        --        
        --    (2) Looking up one OccName in the mini_env will cause
        --        others to be looked up, which might cause that
        --        original one to be looked up again, and hence loop.
        --
        -- The code below works because of the following invariant:
        -- getOccName on a TyThing does not force the suspended type
        -- checks in order to extract the name. For example, we don't
        -- poke on the "T a" type of <selector x> on the way to
        -- extracting <selector x>'s OccName. Of course, there is no
        -- reason in principle why getting the OccName should force the
        -- thunks, but this means we need to be careful in
        -- implicitTyThings and its helper functions.
        --
        -- All a bit too finely-balanced for my liking.

        -- This mini-env and lookup function mediates between the
Thomas Schilling's avatar
Thomas Schilling committed
440
        --'Name's n and the map from 'OccName's to the implicit TyThings
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
441 442 443 444 445
        ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]
              lookup n = case lookupOccEnv mini_env (getOccName n) of
                           Just thing -> thing
                           Nothing    -> 
                             pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl))
446

447
        ; implicit_names <- mapM (lookupOrig mod) (ifaceDeclImplicitBndrs decl)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
448
        ; return $ (main_name, thing) :
449 450 451
                      -- uses the invariant that implicit_names and
                      -- implictTyThings are bijective
                      [(n, lookup n) | n <- implicit_names]
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
452
        }
453
  where
Ian Lynagh's avatar
Ian Lynagh committed
454
    doc = ptext (sLit "Declaration for") <+> ppr (ifName decl)
455

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
456
bumpDeclStats :: Name -> IfL ()         -- Record that one more declaration has actually been used
457
bumpDeclStats name
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
458 459 460 461
  = do  { traceIf (text "Loading decl for" <+> ppr name)
        ; updateEps_ (\eps -> let stats = eps_stats eps
                              in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })
        }
462 463 464 465
\end{code}


%*********************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
466
%*                                                      *
467
\subsection{Reading an interface file}
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
468
%*                                                      *
469 470 471
%*********************************************************

\begin{code}
Simon Marlow's avatar
Simon Marlow committed
472
findAndReadIface :: SDoc -> Module
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
473 474
                 -> IsBootInterface     -- True  <=> Look for a .hi-boot file
                                        -- False <=> Look for .hi file
475
                 -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
476 477
        -- Nothing <=> file not found, or unreadable, or illegible
        -- Just x  <=> successfully found and parsed 
478

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
479 480
        -- It *doesn't* add an error to the monad, because 
        -- sometimes it's ok to fail... see notes with loadInterface
481

Simon Marlow's avatar
Simon Marlow committed
482
findAndReadIface doc_str mod hi_boot_file
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
483 484 485 486 487 488 489 490 491
  = do  { traceIf (sep [hsep [ptext (sLit "Reading"), 
                              if hi_boot_file 
                                then ptext (sLit "[boot]") 
                                else empty,
                              ptext (sLit "interface for"), 
                              ppr mod <> semi],
                        nest 4 (ptext (sLit "reason:") <+> doc_str)])

        -- Check for GHC.Prim, and return its static interface
492
        ; dflags <- getDynFlags
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
493 494 495 496 497 498 499 500 501
        ; if mod == gHC_PRIM
          then return (Succeeded (ghcPrimIface,
                                   "<built in interface for GHC.Prim>"))
          else do

        -- Look for the file
        ; hsc_env <- getTopEnv
        ; mb_found <- liftIO (findExactModule hsc_env mod)
        ; case mb_found of {
Simon Marlow's avatar
Simon Marlow committed
502
              
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
503
              Found loc mod -> do 
504

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
505 506
        -- Found file, so read it
        { let { file_path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) }
Simon Marlow's avatar
Simon Marlow committed
507

508 509 510
        -- If the interface is in the current package then if we could
        -- load it would already be in the HPT and we assume that our
        -- callers checked that.
Simon Marlow's avatar
Simon Marlow committed
511 512
        ; if thisPackage dflags == modulePackageId mod
                && not (isOneShot (ghcMode dflags))
513
            then return (Failed (homeModError mod loc))
Simon Marlow's avatar
Simon Marlow committed
514 515
            else do {

Ian Lynagh's avatar
Ian Lynagh committed
516
        ; traceIf (ptext (sLit "readIFace") <+> text file_path)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
517 518 519 520 521 522 523 524 525 526 527 528
        ; read_result <- readIface mod file_path hi_boot_file
        ; case read_result of
            Failed err -> return (Failed (badIfaceFile file_path err))
            Succeeded iface 
                | mi_module iface /= mod ->
                  return (Failed (wrongIfaceModErr iface mod file_path))
                | otherwise ->
                  return (Succeeded (iface, file_path))
                        -- Don't forget to fill in the package name...
        }}
            ; err -> do
                { traceIf (ptext (sLit "...not found"))
529
                ; dflags <- getDynFlags
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
530 531
                ; return (Failed (cannotFindInterface dflags 
                                        (moduleName mod) err)) }
Ian Lynagh's avatar
Ian Lynagh committed
532 533
        }
        }
534 535 536 537 538
\end{code}

@readIface@ tries just the one file.

\begin{code}
Simon Marlow's avatar
Simon Marlow committed
539
readIface :: Module -> FilePath -> IsBootInterface 
540
          -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
541 542
        -- Failed err    <=> file not found, or unreadable, or illegible
        -- Succeeded iface <=> successfully found and parsed 
543

Ian Lynagh's avatar
Ian Lynagh committed
544
readIface wanted_mod file_path _
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
545
  = do  { res <- tryMostM $
546
                 readBinIface CheckHiWay QuietBinIFaceReading file_path
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
547 548 549 550 551 552 553 554 555
        ; case res of
            Right iface 
                | wanted_mod == actual_mod -> return (Succeeded iface)
                | otherwise                -> return (Failed err)
                where
                  actual_mod = mi_module iface
                  err = hiModuleNameMismatchWarn wanted_mod actual_mod

            Left exn    -> return (Failed (text (showException exn)))
556
    }
557 558 559 560
\end{code}


%*********************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
561 562 563
%*                                                       *
        Wired-in interface for GHC.Prim
%*                                                       *
564 565 566 567 568 569
%*********************************************************

\begin{code}
initExternalPackageState :: ExternalPackageState
initExternalPackageState
  = EPS { 
570 571 572 573 574 575
      eps_is_boot      = emptyUFM,
      eps_PIT          = emptyPackageIfaceTable,
      eps_PTE          = emptyTypeEnv,
      eps_inst_env     = emptyInstEnv,
      eps_fam_inst_env = emptyFamInstEnv,
      eps_rule_base    = mkRuleBase builtinRules,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
576
        -- Initialise the EPS rule pool with the built-in rules
577 578
      eps_mod_fam_inst_env
                       = emptyModuleEnv,
579
      eps_vect_info    = noVectInfo,
580
      eps_ann_env      = emptyAnnEnv,
581
      eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
582 583
                           , n_insts_in = 0, n_insts_out = 0
                           , n_rules_in = length builtinRules, n_rules_out = 0 }
584 585 586 587 588
    }
\end{code}


%*********************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
589 590 591
%*                                                       *
        Wired-in interface for GHC.Prim
%*                                                       *
592 593 594 595 596
%*********************************************************

\begin{code}
ghcPrimIface :: ModIface
ghcPrimIface
Simon Marlow's avatar
Simon Marlow committed
597
  = (emptyModIface gHC_PRIM) {
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
598 599 600 601 602
        mi_exports  = ghcPrimExports,
        mi_decls    = [],
        mi_fixities = fixities,
        mi_fix_fn  = mkIfaceFixCache fixities
    }           
603 604
  where
    fixities = [(getOccName seqId, Fixity 0 InfixR)]
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
605
                        -- seq is infixr 0
606 607 608
\end{code}

%*********************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
609
%*                                                      *
610
\subsection{Statistics}
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
611
%*                                                      *
612 613 614 615 616
%*********************************************************

\begin{code}
ifaceStats :: ExternalPackageState -> SDoc
ifaceStats eps 
617
  = hcat [text "Renamer stats: ", msg]
618
  where
619 620
    stats = eps_stats eps
    msg = vcat 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
621 622 623 624 625 626 627 628
        [int (n_ifaces_in stats) <+> text "interfaces read",
         hsep [ int (n_decls_out stats), text "type/class/variable imported, out of", 
                int (n_decls_in stats), text "read"],
         hsep [ int (n_insts_out stats), text "instance decls imported, out of",  
                int (n_insts_in stats), text "read"],
         hsep [ int (n_rules_out stats), text "rule decls imported, out of",  
                int (n_rules_in stats), text "read"]
        ]
SamB's avatar
SamB committed
629
\end{code}
630 631


632
%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
633 634 635
%*                                                                      *
                Printing interfaces
%*                                                                      *
636 637 638
%************************************************************************

\begin{code}
639 640 641
-- | Read binary interface, and print it out
showIface :: HscEnv -> FilePath -> IO ()
showIface hsc_env filename = do
Ian Lynagh's avatar
Ian Lynagh committed
642
   -- skip the hi way check; we don't want to worry about profiled vs.
643
   -- non-profiled interfaces, for example.
644 645
   iface <- initTcRnIf 's' hsc_env () () $
       readBinIface IgnoreHiWay TraceBinIFaceReading filename
646 647 648 649 650 651 652
   printDump (pprModIface iface)
\end{code}

\begin{code}
pprModIface :: ModIface -> SDoc
-- Show a ModIface
pprModIface iface
Ian Lynagh's avatar
Ian Lynagh committed
653
 = vcat [ ptext (sLit "interface")
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
654 655 656 657 658
                <+> ppr (mi_module iface) <+> pp_boot
                <+> (if mi_orphan iface then ptext (sLit "[orphan module]") else empty)
                <+> (if mi_finsts iface then ptext (sLit "[family instance module]") else empty)
                <+> (if mi_hpc    iface then ptext (sLit "[hpc]") else empty)
                <+> integer opt_HiVersion
659 660 661 662
        , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash iface))
        , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface))
        , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface))
        , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface))
663
        , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash iface))
664
        , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface))
665
        , nest 2 (ptext (sLit "where"))
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
666
        , ptext (sLit "exports:")
667
        , nest 2 (vcat (map pprExport (mi_exports iface)))
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
668 669 670 671
        , pprDeps (mi_deps iface)
        , vcat (map pprUsage (mi_usages iface))
        , vcat (map pprIfaceAnnotation (mi_anns iface))
        , pprFixities (mi_fixities iface)
672 673 674 675
        , vcat (map pprIfaceDecl (mi_decls iface))
        , vcat (map ppr (mi_insts iface))
        , vcat (map ppr (mi_fam_insts iface))
        , vcat (map ppr (mi_rules iface))
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
676
        , pprVectInfo (mi_vect_info iface)
677 678 679 680
        , ppr (mi_warns iface)
        , pprTrustInfo (mi_trust iface)
        , pprTrustPkg (mi_trust_pkg iface)
        ]
681
  where
Ian Lynagh's avatar
Ian Lynagh committed
682
    pp_boot | mi_boot iface = ptext (sLit "[boot]")
683
            | otherwise     = empty
684 685 686
\end{code}

When printing export lists, we print like this:
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
687 688 689
        Avail   f               f
        AvailTC C [C, x, y]     C(x,y)
        AvailTC C [x, y]        C!(x,y)         -- Exporting x, y but not C
690 691 692

\begin{code}
pprExport :: IfaceExport -> SDoc
693 694 695 696 697 698
pprExport (Avail n)      = ppr n
pprExport (AvailTC _ []) = empty
pprExport (AvailTC n (n':ns)) 
  | n==n'     = ppr n <> pp_export ns
  | otherwise = ppr n <> char '|' <> pp_export (n':ns)
  where  
699 700 701 702
    pp_export []    = empty
    pp_export names = braces (hsep (map ppr names))

pprUsage :: Usage -> SDoc
703
pprUsage usage@UsagePackageModule{}
704
  = pprUsageImport usage usg_mod
705
pprUsage usage@UsageHomeModule{}
706
  = pprUsageImport usage usg_mod_name $$
707
    nest 2 (
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
708
        maybe empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$
709 710
        vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]
        )
GregWeber's avatar
GregWeber committed
711
pprUsage usage@UsageFile{}
712 713
  = hsep [ptext (sLit "addDependentFile"),
          doubleQuotes (text (usg_file_path usage))]
714

715 716 717 718 719 720 721 722
pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc
pprUsageImport usage usg_mod'
  = hsep [ptext (sLit "import"), safe, ppr (usg_mod' usage),
                       ppr (usg_mod_hash usage)]
    where
        safe | usg_safe usage = ptext $ sLit "safe"
             | otherwise      = ptext $ sLit " -/ "

723
pprDeps :: Dependencies -> SDoc
724
pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
725
                dep_finsts = finsts })
Ian Lynagh's avatar
Ian Lynagh committed
726
  = vcat [ptext (sLit "module dependencies:") <+> fsep (map ppr_mod mods),
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
727 728 729 730
          ptext (sLit "package dependencies:") <+> fsep (map ppr_pkg pkgs),
          ptext (sLit "orphans:") <+> fsep (map ppr orphs),
          ptext (sLit "family instance modules:") <+> fsep (map ppr finsts)
        ]
731 732
  where
    ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot
733 734
    ppr_pkg (pkg,trust_req)  = ppr pkg <>
                               (if trust_req then text "*" else empty)
735 736 737
    ppr_boot True  = text "[boot]"
    ppr_boot False = empty

738
pprIfaceDecl :: (Fingerprint, IfaceDecl) -> SDoc
739
pprIfaceDecl (ver, decl)
740
  = ppr ver $$ nest 2 (ppr decl)
741 742 743

pprFixities :: [(OccName, Fixity)] -> SDoc
pprFixities []    = empty
Ian Lynagh's avatar
Ian Lynagh committed
744
pprFixities fixes = ptext (sLit "fixities") <+> pprWithCommas pprFix fixes
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
745 746
                  where
                    pprFix (occ,fix) = ppr fix <+> ppr occ 
747

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
748
pprVectInfo :: IfaceVectInfo -> SDoc
749 750 751 752 753
pprVectInfo (IfaceVectInfo { ifaceVectInfoVar          = vars
                           , ifaceVectInfoTyCon        = tycons
                           , ifaceVectInfoTyConReuse   = tyconsReuse
                           , ifaceVectInfoScalarVars   = scalarVars
                           , ifaceVectInfoScalarTyCons = scalarTyCons
754 755
                           }) = 
  vcat 
Ian Lynagh's avatar
Ian Lynagh committed
756 757 758
  [ ptext (sLit "vectorised variables:") <+> hsep (map ppr vars)
  , ptext (sLit "vectorised tycons:") <+> hsep (map ppr tycons)
  , ptext (sLit "vectorised reused tycons:") <+> hsep (map ppr tyconsReuse)
759 760
  , ptext (sLit "scalar variables:") <+> hsep (map ppr scalarVars)
  , ptext (sLit "scalar tycons:") <+> hsep (map ppr scalarTyCons)
761
  ]
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
762

763 764 765
pprTrustInfo :: IfaceTrustInfo -> SDoc
pprTrustInfo trust = ptext (sLit "trusted:") <+> ppr trust

766 767 768
pprTrustPkg :: Bool -> SDoc
pprTrustPkg tpkg = ptext (sLit "require own pkg trusted:") <+> ppr tpkg

Ian Lynagh's avatar
Ian Lynagh committed
769 770 771 772
instance Outputable Warnings where
    ppr = pprWarns

pprWarns :: Warnings -> SDoc
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
773
pprWarns NoWarnings         = empty
Ian Lynagh's avatar
Ian Lynagh committed
774 775 776 777
pprWarns (WarnAll txt)  = ptext (sLit "Warn all") <+> ppr txt
pprWarns (WarnSome prs) = ptext (sLit "Warnings")
                        <+> vcat (map pprWarning prs)
    where pprWarning (name, txt) = ppr name <+> ppr txt
778 779 780 781

pprIfaceAnnotation :: IfaceAnnotation -> SDoc
pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized })
  = ppr target <+> ptext (sLit "annotated by") <+> ppr serialized
782 783 784
\end{code}


785
%*********************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
786
%*                                                       *
787
\subsection{Errors}
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
788
%*                                                       *
789 790 791
%*********************************************************

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
792
badIfaceFile :: String -> SDoc -> SDoc
793
badIfaceFile file err
Ian Lynagh's avatar
Ian Lynagh committed
794
  = vcat [ptext (sLit "Bad interface file:") <+> text file, 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
795
          nest 4 err]
796

797
hiModuleNameMismatchWarn :: Module -> Module -> MsgDoc
798
hiModuleNameMismatchWarn requested_mod read_mod = 
Simon Marlow's avatar
Simon Marlow committed
799 800 801
  withPprStyle defaultUserStyle $
    -- we want the Modules below to be qualified with package names,
    -- so reset the PrintUnqualified setting.
Ian Lynagh's avatar
Ian Lynagh committed
802
    hsep [ ptext (sLit "Something is amiss; requested module ")
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
803 804 805 806
         , ppr requested_mod
         , ptext (sLit "differs from name found in the interface file")
         , ppr read_mod
         ]
807

Ian Lynagh's avatar
Ian Lynagh committed
808
wrongIfaceModErr :: ModIface -> Module -> String -> SDoc
809
wrongIfaceModErr iface mod_name file_path 
Ian Lynagh's avatar
Ian Lynagh committed
810 811 812
  = sep [ptext (sLit "Interface file") <+> iface_file,
         ptext (sLit "contains module") <+> quotes (ppr (mi_module iface)) <> comma,
         ptext (sLit "but we were expecting module") <+> quotes (ppr mod_name),
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
813 814 815 816 817
         sep [ptext (sLit "Probable cause: the source code which generated"),
             nest 2 iface_file,
             ptext (sLit "has an incompatible module name")
            ]
        ]
818
  where iface_file = doubleQuotes (text file_path)
Simon Marlow's avatar
Simon Marlow committed
819

Ian Lynagh's avatar
Ian Lynagh committed
820
homeModError :: Module -> ModLocation -> SDoc
Simon Marlow's avatar
Simon Marlow committed
821
homeModError mod location
Ian Lynagh's avatar
Ian Lynagh committed
822
  = ptext (sLit "attempting to use module ") <> quotes (ppr mod)
Simon Marlow's avatar
Simon Marlow committed
823 824 825
    <> (case ml_hs_file location of
           Just file -> space <> parens (text file)
           Nothing   -> empty)
Ian Lynagh's avatar
Ian Lynagh committed
826
    <+> ptext (sLit "which is not loaded")
827
\end{code}
828