compiler/main/GHC.hs

   1 -- -----------------------------------------------------------------------------
   2 --
   3 -- (c) The University of Glasgow, 2005
   4 --
   5 -- The GHC API
   6 --
   7 -- -----------------------------------------------------------------------------
   8
   9 module GHC (
  10         -- * Initialisation
  11         Session,
  12         defaultErrorHandler,
  13         defaultCleanupHandler,
  14         newSession,
  15
  16         -- * Flags and settings
  17         DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt,
  18         parseDynamicFlags,
  19         getSessionDynFlags,
  20         setSessionDynFlags,
  21
  22         -- * Targets
  23         Target(..), TargetId(..), Phase,
  24         setTargets,
  25         getTargets,
  26         addTarget,
  27         removeTarget,
  28         guessTarget,
  29
  30         -- * Extending the program scope
  31         extendGlobalRdrScope,  -- :: Session -> [GlobalRdrElt] -> IO ()
  32         setGlobalRdrScope,     -- :: Session -> [GlobalRdrElt] -> IO ()
  33         extendGlobalTypeScope, -- :: Session -> [Id] -> IO ()
  34         setGlobalTypeScope,    -- :: Session -> [Id] -> IO ()
  35
  36         -- * Loading\/compiling the program
  37         depanal,
  38         load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
  39         workingDirectoryChanged,
  40         checkModule, CheckedModule(..),
  41         TypecheckedSource, ParsedSource, RenamedSource,
  42
  43         -- * Inspecting the module structure of the program
  44         ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
  45         getModuleGraph,
  46         isLoaded,
  47         topSortModuleGraph,
  48
  49         -- * Inspecting modules
  50         ModuleInfo,
  51         getModuleInfo,
  52         modInfoTyThings,
  53         modInfoTopLevelScope,
  54         modInfoPrintUnqualified,
  55         modInfoExports,
  56         modInfoInstances,
  57         modInfoIsExportedName,
  58         modInfoLookupName,
  59         lookupGlobalName,
  60
  61         -- * Printing
  62         PrintUnqualified, alwaysQualify,
  63
  64         -- * Interactive evaluation
  65         getBindings, getPrintUnqual,
  66         findModule,
  67 #ifdef GHCI
  68         setContext, getContext,
  69         getNamesInScope,
  70         getRdrNamesInScope,
  71         moduleIsInterpreted,
  72         getInfo,
  73         exprType,
  74         typeKind,
  75         parseName,
  76         RunResult(..),
  77         runStmt,
  78         showModule,
  79         compileExpr, HValue, dynCompileExpr,
  80         lookupName,
  81 #endif
  82
  83         -- * Abstract syntax elements
  84
  85         -- ** Packages
  86         PackageId,
  87
  88         -- ** Modules
  89         Module, mkModule, pprModule, moduleName, modulePackageId,
  90         ModuleName, mkModuleName, moduleNameString,
  91
  92         -- ** Names
  93         Name,
  94         nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc,
  95         NamedThing(..),
  96         RdrName(Qual,Unqual),
  97
  98         -- ** Identifiers
  99         Id, idType,
 100         isImplicitId, isDeadBinder,
 101         isExportedId, isLocalId, isGlobalId,
 102         isRecordSelector,
 103         isPrimOpId, isFCallId, isClassOpId_maybe,
 104         isDataConWorkId, idDataCon,
 105         isBottomingId, isDictonaryId,
 106         recordSelectorFieldLabel,
 107
 108         -- ** Type constructors
 109         TyCon,
 110         tyConTyVars, tyConDataCons, tyConArity,
 111         isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
 112         synTyConDefn, synTyConRhs,
 113
 114         -- ** Type variables
 115         TyVar,
 116         alphaTyVars,
 117
 118         -- ** Data constructors
 119         DataCon,
 120         dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
 121         dataConIsInfix, isVanillaDataCon,
 122         dataConStrictMarks,
 123         StrictnessMark(..), isMarkedStrict,
 124
 125         -- ** Classes
 126         Class,
 127         classMethods, classSCTheta, classTvsFds,
 128         pprFundeps,
 129
 130         -- ** Instances
 131         Instance,
 132         instanceDFunId, pprInstance, pprInstanceHdr,
 133
 134         -- ** Types and Kinds
 135         Type, dropForAlls, splitForAllTys, funResultTy, pprParendType,
 136         Kind,
 137         PredType,
 138         ThetaType, pprThetaArrow,
 139
 140         -- ** Entities
 141         TyThing(..),
 142
 143         -- ** Syntax
 144         module HsSyn, -- ToDo: remove extraneous bits
 145
 146         -- ** Fixities
 147         FixityDirection(..),
 148         defaultFixity, maxPrecedence,
 149         negateFixity,
 150         compareFixity,
 151
 152         -- ** Source locations
 153         SrcLoc, pprDefnLoc,
 154
 155         -- * Exceptions
 156         GhcException(..), showGhcException,
 157
 158         -- * Miscellaneous
 159         sessionHscEnv,
 160         cyclicModuleErr,
 161   ) where
 162
 163 {-
 164  ToDo:
 165
 166   * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
 167   * what StaticFlags should we expose, if any?
 168 -}
 169
 170 #include "HsVersions.h"
 171
 172 #ifdef GHCI
 173 import qualified Linker
 174 import Data.Dynamic     ( Dynamic )
 175 import Linker           ( HValue, extendLinkEnv )
 176 import TcRnDriver       ( tcRnLookupRdrName, tcRnGetInfo,
 177                           tcRnLookupName, getModuleExports )
 178 import RdrName          ( plusGlobalRdrEnv, Provenance(..),
 179                           ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
 180                           mkGlobalRdrEnv )
 181 import HscMain          ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType )
 182 import Name             ( nameOccName )
 183 import Type             ( tidyType )
 184 import VarEnv           ( emptyTidyEnv )
 185 import GHC.Exts         ( unsafeCoerce# )
 186 #endif
 187
 188 import Packages         ( initPackages )
 189 import NameSet          ( NameSet, nameSetToList, elemNameSet )
 190 import RdrName          ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..),
 191                           globalRdrEnvElts, extendGlobalRdrEnv,
 192                           emptyGlobalRdrEnv )
 193 import HsSyn
 194 import Type             ( Kind, Type, dropForAlls, PredType, ThetaType,
 195                           pprThetaArrow, pprParendType, splitForAllTys,
 196                           funResultTy )
 197 import Id               ( Id, idType, isImplicitId, isDeadBinder,
 198                           isExportedId, isLocalId, isGlobalId,
 199                           isRecordSelector, recordSelectorFieldLabel,
 200                           isPrimOpId, isFCallId, isClassOpId_maybe,
 201                           isDataConWorkId, idDataCon,
 202                           isBottomingId )
 203 import Var              ( TyVar )
 204 import TysPrim          ( alphaTyVars )
 205 import TyCon            ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
 206                           isPrimTyCon, isFunTyCon, tyConArity,
 207                           tyConTyVars, tyConDataCons, synTyConDefn, synTyConRhs )
 208 import Class            ( Class, classSCTheta, classTvsFds, classMethods )
 209 import FunDeps          ( pprFundeps )
 210 import DataCon          ( DataCon, dataConWrapId, dataConSig, dataConTyCon,
 211                           dataConFieldLabels, dataConStrictMarks,
 212                           dataConIsInfix, isVanillaDataCon )
 213 import Name             ( Name, nameModule, NamedThing(..), nameParent_maybe,
 214                           nameSrcLoc )
 215 import OccName          ( parenSymOcc )
 216 import NameEnv          ( nameEnvElts )
 217 import InstEnv          ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
 218 import SrcLoc
 219 import DriverPipeline
 220 import DriverPhases     ( Phase(..), isHaskellSrcFilename, startPhase )
 221 import HeaderInfo       ( getImports, getOptions )
 222 import Finder
 223 import HscMain          ( newHscEnv, hscFileCheck, HscChecked(..) )
 224 import HscTypes
 225 import DynFlags
 226 import SysTools     ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
 227                       cleanTempDirs )
 228 import Module
 229 import UniqFM
 230 import PackageConfig    ( PackageId, stringToPackageId )
 231 import FiniteMap
 232 import Panic
 233 import Digraph
 234 import Bag              ( unitBag )
 235 import ErrUtils         ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg,
 236                           mkPlainErrMsg, printBagOfErrors )
 237 import qualified ErrUtils
 238 import Util
 239 import StringBuffer     ( StringBuffer, hGetStringBuffer )
 240 import Outputable
 241 import BasicTypes
 242 import TcType           ( tcSplitSigmaTy, isDictTy )
 243 import Maybes           ( expectJust, mapCatMaybes )
 244
 245 import Control.Concurrent
 246 import System.Directory ( getModificationTime, doesFileExist )
 247 import Data.Maybe       ( isJust, isNothing )
 248 import Data.List        ( partition, nub )
 249 import qualified Data.List as List
 250 import Control.Monad    ( unless, when )
 251 import System.Exit      ( exitWith, ExitCode(..) )
 252 import System.Time      ( ClockTime )
 253 import Control.Exception as Exception hiding (handle)
 254 import Data.IORef
 255 import System.IO
 256 import System.IO.Error  ( isDoesNotExistError )
 257 import Prelude hiding (init)
 258
 259 #if __GLASGOW_HASKELL__ < 600
 260 import System.IO as System.IO.Error ( try )
 261 #else
 262 import System.IO.Error  ( try )
 263 #endif
 264
 265 -- -----------------------------------------------------------------------------
 266 -- Exception handlers
 267
 268 -- | Install some default exception handlers and run the inner computation.
 269 -- Unless you want to handle exceptions yourself, you should wrap this around
 270 -- the top level of your program.  The default handlers output the error
 271 -- message(s) to stderr and exit cleanly.
 272 defaultErrorHandler :: DynFlags -> IO a -> IO a
 273 defaultErrorHandler dflags inner =
 274   -- top-level exception handler: any unrecognised exception is a compiler bug.
 275   handle (\exception -> do
 276            hFlush stdout
 277            case exception of
 278                 -- an IO exception probably isn't our fault, so don't panic
 279                 IOException _ ->
 280                   fatalErrorMsg dflags (text (show exception))
 281                 AsyncException StackOverflow ->
 282                   fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
 283                 _other ->
 284                   fatalErrorMsg dflags (text (show (Panic (show exception))))
 285            exitWith (ExitFailure 1)
 286          ) $
 287
 288   -- program errors: messages with locations attached.  Sometimes it is
 289   -- convenient to just throw these as exceptions.
 290   handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn)
 291                         exitWith (ExitFailure 1)) $
 292
 293   -- error messages propagated as exceptions
 294   handleDyn (\dyn -> do
 295                 hFlush stdout
 296                 case dyn of
 297                      PhaseFailed _ code -> exitWith code
 298                      Interrupted -> exitWith (ExitFailure 1)
 299                      _ -> do fatalErrorMsg dflags (text (show (dyn :: GhcException)))
 300                              exitWith (ExitFailure 1)
 301             ) $
 302   inner
 303
 304 -- | Install a default cleanup handler to remove temporary files
 305 -- deposited by a GHC run.  This is seperate from
 306 -- 'defaultErrorHandler', because you might want to override the error
 307 -- handling, but still get the ordinary cleanup behaviour.
 308 defaultCleanupHandler :: DynFlags -> IO a -> IO a
 309 defaultCleanupHandler dflags inner =
 310     -- make sure we clean up after ourselves
 311     later (unless (dopt Opt_KeepTmpFiles dflags) $
 312                do cleanTempFiles dflags
 313                   cleanTempDirs dflags
 314           )
 315           -- exceptions will be blocked while we clean the temporary files,
 316           -- so there shouldn't be any difficulty if we receive further
 317           -- signals.
 318     inner
 319
 320
 321 -- | Starts a new session.  A session consists of a set of loaded
 322 -- modules, a set of options (DynFlags), and an interactive context.
 323 -- ToDo: GhcMode should say "keep typechecked code" and\/or "keep renamed
 324 -- code".
 325 newSession :: GhcMode -> Maybe FilePath -> IO Session
 326 newSession mode mb_top_dir = do
 327   -- catch ^C
 328   main_thread <- myThreadId
 329   putMVar interruptTargetThread [main_thread]
 330   installSignalHandlers
 331
 332   dflags0 <- initSysTools mb_top_dir defaultDynFlags
 333   dflags  <- initDynFlags dflags0
 334   env <- newHscEnv dflags{ ghcMode=mode }
 335   ref <- newIORef env
 336   return (Session ref)
 337
 338 -- tmp: this breaks the abstraction, but required because DriverMkDepend
 339 -- needs to call the Finder.  ToDo: untangle this.
 340 sessionHscEnv :: Session -> IO HscEnv
 341 sessionHscEnv (Session ref) = readIORef ref
 342
 343 withSession :: Session -> (HscEnv -> IO a) -> IO a
 344 withSession (Session ref) f = do h <- readIORef ref; f h
 345
 346 modifySession :: Session -> (HscEnv -> HscEnv) -> IO ()
 347 modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h
 348
 349 -- -----------------------------------------------------------------------------
 350 -- Flags & settings
 351
 352 -- | Grabs the DynFlags from the Session
 353 getSessionDynFlags :: Session -> IO DynFlags
 354 getSessionDynFlags s = withSession s (return . hsc_dflags)
 355
 356 -- | Updates the DynFlags in a Session.  This also reads
 357 -- the package database (unless it has already been read),
 358 -- and prepares the compilers knowledge about packages.  It
 359 -- can be called again to load new packages: just add new
 360 -- package flags to (packageFlags dflags).
 361 --
 362 -- Returns a list of new packages that may need to be linked in using
 363 -- the dynamic linker (see 'linkPackages') as a result of new package
 364 -- flags.  If you are not doing linking or doing static linking, you
 365 -- can ignore the list of packages returned.
 366 --
 367 setSessionDynFlags :: Session -> DynFlags -> IO [PackageId]
 368 setSessionDynFlags (Session ref) dflags = do
 369   hsc_env <- readIORef ref
 370   (dflags', preload) <- initPackages dflags
 371   writeIORef ref $! hsc_env{ hsc_dflags = dflags' }
 372   return preload
 373
 374 -- | If there is no -o option, guess the name of target executable
 375 -- by using top-level source file name as a base.
 376 guessOutputFile :: Session -> IO ()
 377 guessOutputFile s = modifySession s $ \env ->
 378     let dflags = hsc_dflags env
 379         mod_graph = hsc_mod_graph env
 380         mainModuleSrcPath, guessedName :: Maybe String
 381         mainModuleSrcPath = do
 382             let isMain = (== mainModIs dflags) . ms_mod
 383             [ms] <- return (filter isMain mod_graph)
 384             ml_hs_file (ms_location ms)
 385         guessedName = fmap basenameOf mainModuleSrcPath
 386     in
 387     case outputFile dflags of
 388         Just _ -> env
 389         Nothing -> env { hsc_dflags = dflags { outputFile = guessedName } }
 390
 391 -- -----------------------------------------------------------------------------
 392 -- Targets
 393
 394 -- ToDo: think about relative vs. absolute file paths. And what
 395 -- happens when the current directory changes.
 396
 397 -- | Sets the targets for this session.  Each target may be a module name
 398 -- or a filename.  The targets correspond to the set of root modules for
 399 -- the program\/library.  Unloading the current program is achieved by
 400 -- setting the current set of targets to be empty, followed by load.
 401 setTargets :: Session -> [Target] -> IO ()
 402 setTargets s targets = modifySession s (\h -> h{ hsc_targets = targets })
 403
 404 -- | returns the current set of targets
 405 getTargets :: Session -> IO [Target]
 406 getTargets s = withSession s (return . hsc_targets)
 407
 408 -- | Add another target
 409 addTarget :: Session -> Target -> IO ()
 410 addTarget s target
 411   = modifySession s (\h -> h{ hsc_targets = target : hsc_targets h })
 412
 413 -- | Remove a target
 414 removeTarget :: Session -> TargetId -> IO ()
 415 removeTarget s target_id
 416   = modifySession s (\h -> h{ hsc_targets = filter (hsc_targets h) })
 417   where
 418    filter targets = [ t | t@(Target id _) <- targets, id /= target_id ]
 419
 420 -- Attempts to guess what Target a string refers to.  This function implements
 421 -- the --make/GHCi command-line syntax for filenames:
 422 --
 423 --      - if the string looks like a Haskell source filename, then interpret
 424 --        it as such
 425 --      - if adding a .hs or .lhs suffix yields the name of an existing file,
 426 --        then use that
 427 --      - otherwise interpret the string as a module name
 428 --
 429 guessTarget :: String -> Maybe Phase -> IO Target
 430 guessTarget file (Just phase)
 431    = return (Target (TargetFile file (Just phase)) Nothing)
 432 guessTarget file Nothing
 433    | isHaskellSrcFilename file
 434    = return (Target (TargetFile file Nothing) Nothing)
 435    | otherwise
 436    = do exists <- doesFileExist hs_file
 437         if exists
 438            then return (Target (TargetFile hs_file Nothing) Nothing)
 439            else do
 440         exists <- doesFileExist lhs_file
 441         if exists
 442            then return (Target (TargetFile lhs_file Nothing) Nothing)
 443            else do
 444         return (Target (TargetModule (mkModuleName file)) Nothing)
 445      where
 446          hs_file  = file `joinFileExt` "hs"
 447          lhs_file = file `joinFileExt` "lhs"
 448
 449 -- -----------------------------------------------------------------------------
 450 -- Extending the program scope
 451
 452 extendGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO ()
 453 extendGlobalRdrScope session rdrElts
 454     = modifySession session $ \hscEnv ->
 455       let global_rdr = hsc_global_rdr_env hscEnv
 456       in hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv global_rdr rdrElts }
 457
 458 setGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO ()
 459 setGlobalRdrScope session rdrElts
 460     = modifySession session $ \hscEnv ->
 461       hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv rdrElts }
 462
 463 extendGlobalTypeScope :: Session -> [Id] -> IO ()
 464 extendGlobalTypeScope session ids
 465     = modifySession session $ \hscEnv ->
 466       let global_type = hsc_global_type_env hscEnv
 467       in hscEnv{ hsc_global_type_env = extendTypeEnvWithIds global_type ids }
 468
 469 setGlobalTypeScope :: Session -> [Id] -> IO ()
 470 setGlobalTypeScope session ids
 471     = modifySession session $ \hscEnv ->
 472       hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }
 473
 474 -- -----------------------------------------------------------------------------
 475 -- Loading the program
 476
 477 -- Perform a dependency analysis starting from the current targets
 478 -- and update the session with the new module graph.
 479 depanal :: Session -> [ModuleName] -> Bool -> IO (Maybe ModuleGraph)
 480 depanal (Session ref) excluded_mods allow_dup_roots = do
 481   hsc_env <- readIORef ref
 482   let
 483          dflags  = hsc_dflags hsc_env
 484          gmode   = ghcMode (hsc_dflags hsc_env)
 485          targets = hsc_targets hsc_env
 486          old_graph = hsc_mod_graph hsc_env
 487
 488   showPass dflags "Chasing dependencies"
 489   when (gmode == BatchCompile) $
 490         debugTraceMsg dflags 2 (hcat [
 491                      text "Chasing modules from: ",
 492                         hcat (punctuate comma (map pprTarget targets))])
 493
 494   r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
 495   case r of
 496     Just mod_graph -> writeIORef ref hsc_env{ hsc_mod_graph = mod_graph }
 497     _ -> return ()
 498   return r
 499
 500 {-
 501 -- | The result of load.
 502 data LoadResult
 503   = LoadOk      Errors  -- ^ all specified targets were loaded successfully.
 504   | LoadFailed  Errors  -- ^ not all modules were loaded.
 505
 506 type Errors = [String]
 507
 508 data ErrMsg = ErrMsg {
 509         errMsgSeverity  :: Severity,  -- warning, error, etc.
 510         errMsgSpans     :: [SrcSpan],
 511         errMsgShortDoc  :: Doc,
 512         errMsgExtraInfo :: Doc
 513         }
 514 -}
 515
 516 data LoadHowMuch
 517    = LoadAllTargets
 518    | LoadUpTo ModuleName
 519    | LoadDependenciesOf ModuleName
 520
 521 -- | Try to load the program.  If a Module is supplied, then just
 522 -- attempt to load up to this target.  If no Module is supplied,
 523 -- then try to load all targets.
 524 load :: Session -> LoadHowMuch -> IO SuccessFlag
 525 load s@(Session ref) how_much
 526    = do
 527         -- Dependency analysis first.  Note that this fixes the module graph:
 528         -- even if we don't get a fully successful upsweep, the full module
 529         -- graph is still retained in the Session.  We can tell which modules
 530         -- were successfully loaded by inspecting the Session's HPT.
 531         mb_graph <- depanal s [] False
 532         case mb_graph of
 533            Just mod_graph -> load2 s how_much mod_graph
 534            Nothing        -> return Failed
 535
 536 load2 s@(Session ref) how_much mod_graph = do
 537         guessOutputFile s
 538         hsc_env <- readIORef ref
 539
 540         let hpt1      = hsc_HPT hsc_env
 541         let dflags    = hsc_dflags hsc_env
 542         let ghci_mode = ghcMode dflags -- this never changes
 543
 544         -- The "bad" boot modules are the ones for which we have
 545         -- B.hs-boot in the module graph, but no B.hs
 546         -- The downsweep should have ensured this does not happen
 547         -- (see msDeps)
 548         let all_home_mods = [ms_mod_name s
 549                             | s <- mod_graph, not (isBootSummary s)]
 550 #ifdef DEBUG
 551             bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,
 552                                         not (ms_mod_name s `elem` all_home_mods)]
 553 #endif
 554         ASSERT( null bad_boot_mods ) return ()
 555
 556         -- mg2_with_srcimps drops the hi-boot nodes, returning a
 557         -- graph with cycles.  Among other things, it is used for
 558         -- backing out partially complete cycles following a failed
 559         -- upsweep, and for removing from hpt all the modules
 560         -- not in strict downwards closure, during calls to compile.
 561         let mg2_with_srcimps :: [SCC ModSummary]
 562             mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
 563
 564             -- check the stability property for each module.
 565             stable_mods@(stable_obj,stable_bco)
 566                 | BatchCompile <- ghci_mode = ([],[])
 567                 | otherwise = checkStability hpt1 mg2_with_srcimps all_home_mods
 568
 569             -- prune bits of the HPT which are definitely redundant now,
 570             -- to save space.
 571             pruned_hpt = pruneHomePackageTable hpt1
 572                                 (flattenSCCs mg2_with_srcimps)
 573                                 stable_mods
 574
 575         evaluate pruned_hpt
 576
 577         debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
 578                                 text "Stable BCO:" <+> ppr stable_bco)
 579
 580         -- Unload any modules which are going to be re-linked this time around.
 581         let stable_linkables = [ linkable
 582                                | m <- stable_obj++stable_bco,
 583                                  Just hmi <- [lookupUFM pruned_hpt m],
 584                                  Just linkable <- [hm_linkable hmi] ]
 585         unload hsc_env stable_linkables
 586
 587         -- We could at this point detect cycles which aren't broken by
 588         -- a source-import, and complain immediately, but it seems better
 589         -- to let upsweep_mods do this, so at least some useful work gets
 590         -- done before the upsweep is abandoned.
 591         --hPutStrLn stderr "after tsort:\n"
 592         --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
 593
 594         -- Now do the upsweep, calling compile for each module in
 595         -- turn.  Final result is version 3 of everything.
 596
 597         -- Topologically sort the module graph, this time including hi-boot
 598         -- nodes, and possibly just including the portion of the graph
 599         -- reachable from the module specified in the 2nd argument to load.
 600         -- This graph should be cycle-free.
 601         -- If we're restricting the upsweep to a portion of the graph, we
 602         -- also want to retain everything that is still stable.
 603         let full_mg :: [SCC ModSummary]
 604             full_mg    = topSortModuleGraph False mod_graph Nothing
 605
 606             maybe_top_mod = case how_much of
 607                                 LoadUpTo m           -> Just m
 608                                 LoadDependenciesOf m -> Just m
 609                                 _                    -> Nothing
 610
 611             partial_mg0 :: [SCC ModSummary]
 612             partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
 613
 614             -- LoadDependenciesOf m: we want the upsweep to stop just
 615             -- short of the specified module (unless the specified module
 616             -- is stable).
 617             partial_mg
 618                 | LoadDependenciesOf mod <- how_much
 619                 = ASSERT( case last partial_mg0 of
 620                             AcyclicSCC ms -> ms_mod_name ms == mod; _ -> False )
 621                   List.init partial_mg0
 622                 | otherwise
 623                 = partial_mg0
 624
 625             stable_mg =
 626                 [ AcyclicSCC ms
 627                 | AcyclicSCC ms <- full_mg,
 628                   ms_mod_name ms `elem` stable_obj++stable_bco,
 629                   ms_mod_name ms `notElem` [ ms_mod_name ms' |
 630                                                 AcyclicSCC ms' <- partial_mg ] ]
 631
 632             mg = stable_mg ++ partial_mg
 633
 634         -- clean up between compilations
 635         let cleanup = cleanTempFilesExcept dflags
 636                           (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
 637
 638         (upsweep_ok, hsc_env1, modsUpswept)
 639            <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
 640                            pruned_hpt stable_mods cleanup mg
 641
 642         -- Make modsDone be the summaries for each home module now
 643         -- available; this should equal the domain of hpt3.
 644         -- Get in in a roughly top .. bottom order (hence reverse).
 645
 646         let modsDone = reverse modsUpswept
 647
 648         -- Try and do linking in some form, depending on whether the
 649         -- upsweep was completely or only partially successful.
 650
 651         if succeeded upsweep_ok
 652
 653          then
 654            -- Easy; just relink it all.
 655            do debugTraceMsg dflags 2 (text "Upsweep completely successful.")
 656
 657               -- Clean up after ourselves
 658               cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
 659
 660               -- Issue a warning for the confusing case where the user
 661               -- said '-o foo' but we're not going to do any linking.
 662               -- We attempt linking if either (a) one of the modules is
 663               -- called Main, or (b) the user said -no-hs-main, indicating
 664               -- that main() is going to come from somewhere else.
 665               --
 666               let ofile = outputFile dflags
 667               let no_hs_main = dopt Opt_NoHsMain dflags
 668               let
 669                 main_mod = mainModIs dflags
 670                 a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
 671                 do_linking = a_root_is_Main || no_hs_main
 672
 673               when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $
 674                 debugTraceMsg dflags 1 (text ("Warning: output was redirected with -o, " ++
 675                                               "but no output will be generated\n" ++
 676                                               "because there is no " ++ moduleNameString (moduleName main_mod) ++ " module."))
 677
 678               -- link everything together
 679               linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1)
 680
 681               loadFinish Succeeded linkresult ref hsc_env1
 682
 683          else
 684            -- Tricky.  We need to back out the effects of compiling any
 685            -- half-done cycles, both so as to clean up the top level envs
 686            -- and to avoid telling the interactive linker to link them.
 687            do debugTraceMsg dflags 2 (text "Upsweep partially successful.")
 688
 689               let modsDone_names
 690                      = map ms_mod modsDone
 691               let mods_to_zap_names
 692                      = findPartiallyCompletedCycles modsDone_names
 693                           mg2_with_srcimps
 694               let mods_to_keep
 695                      = filter ((`notElem` mods_to_zap_names).ms_mod)
 696                           modsDone
 697
 698               let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
 699                                               (hsc_HPT hsc_env1)
 700
 701               -- Clean up after ourselves
 702               cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)
 703
 704               -- there should be no Nothings where linkables should be, now
 705               ASSERT(all (isJust.hm_linkable)
 706                         (eltsUFM (hsc_HPT hsc_env))) do
 707
 708               -- Link everything together
 709               linkresult <- link ghci_mode dflags False hpt4
 710
 711               let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
 712               loadFinish Failed linkresult ref hsc_env4
 713
 714 -- Finish up after a load.
 715
 716 -- If the link failed, unload everything and return.
 717 loadFinish all_ok Failed ref hsc_env
 718   = do unload hsc_env []
 719        writeIORef ref $! discardProg hsc_env
 720        return Failed
 721
 722 -- Empty the interactive context and set the module context to the topmost
 723 -- newly loaded module, or the Prelude if none were loaded.
 724 loadFinish all_ok Succeeded ref hsc_env
 725   = do writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext }
 726        return all_ok
 727
 728
 729 -- Forget the current program, but retain the persistent info in HscEnv
 730 discardProg :: HscEnv -> HscEnv
 731 discardProg hsc_env
 732   = hsc_env { hsc_mod_graph = emptyMG,
 733               hsc_IC = emptyInteractiveContext,
 734               hsc_HPT = emptyHomePackageTable }
 735
 736 -- used to fish out the preprocess output files for the purposes of
 737 -- cleaning up.  The preprocessed file *might* be the same as the
 738 -- source file, but that doesn't do any harm.
 739 ppFilesFromSummaries summaries = map ms_hspp_file summaries
 740
 741 -- -----------------------------------------------------------------------------
 742 -- Check module
 743
 744 data CheckedModule =
 745   CheckedModule { parsedSource      :: ParsedSource,
 746                   renamedSource     :: Maybe RenamedSource,
 747                   typecheckedSource :: Maybe TypecheckedSource,
 748                   checkedModuleInfo :: Maybe ModuleInfo
 749                 }
 750         -- ToDo: improvements that could be made here:
 751         --  if the module succeeded renaming but not typechecking,
 752         --  we can still get back the GlobalRdrEnv and exports, so
 753         --  perhaps the ModuleInfo should be split up into separate
 754         --  fields within CheckedModule.
 755
 756 type ParsedSource      = Located (HsModule RdrName)
 757 type RenamedSource     = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name])
 758 type TypecheckedSource = LHsBinds Id
 759
 760 -- NOTE:
 761 --   - things that aren't in the output of the typechecker right now:
 762 --     - the export list
 763 --     - the imports
 764 --     - type signatures
 765 --     - type/data/newtype declarations
 766 --     - class declarations
 767 --     - instances
 768 --   - extra things in the typechecker's output:
 769 --     - default methods are turned into top-level decls.
 770 --     - dictionary bindings
 771
 772
 773 -- | This is the way to get access to parsed and typechecked source code
 774 -- for a module.  'checkModule' loads all the dependencies of the specified
 775 -- module in the Session, and then attempts to typecheck the module.  If
 776 -- successful, it returns the abstract syntax for the module.
 777 checkModule :: Session -> ModuleName -> IO (Maybe CheckedModule)
 778 checkModule session@(Session ref) mod = do
 779         -- load up the dependencies first
 780    r <- load session (LoadDependenciesOf mod)
 781    if (failed r) then return Nothing else do
 782
 783         -- now parse & typecheck the module
 784    hsc_env <- readIORef ref
 785    let mg  = hsc_mod_graph hsc_env
 786    case [ ms | ms <- mg, ms_mod_name ms == mod ] of
 787         [] -> return Nothing
 788         (ms:_) -> do
 789            mbChecked <- hscFileCheck hsc_env{hsc_dflags=ms_hspp_opts ms} ms
 790            case mbChecked of
 791              Nothing -> return Nothing
 792              Just (HscChecked parsed renamed Nothing) ->
 793                    return (Just (CheckedModule {
 794                                         parsedSource = parsed,
 795                                         renamedSource = renamed,
 796                                         typecheckedSource = Nothing,
 797                                         checkedModuleInfo = Nothing }))
 798              Just (HscChecked parsed renamed
 799                            (Just (tc_binds, rdr_env, details))) -> do
 800                    let minf = ModuleInfo {
 801                                 minf_type_env  = md_types details,
 802                                 minf_exports   = md_exports details,
 803                                 minf_rdr_env   = Just rdr_env,
 804                                 minf_instances = md_insts details
 805                               }
 806                    return (Just (CheckedModule {
 807                                         parsedSource = parsed,
 808                                         renamedSource = renamed,
 809                                         typecheckedSource = Just tc_binds,
 810                                         checkedModuleInfo = Just minf }))
 811
 812 -- ---------------------------------------------------------------------------
 813 -- Unloading
 814
 815 unload :: HscEnv -> [Linkable] -> IO ()
 816 unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
 817   = case ghcMode (hsc_dflags hsc_env) of
 818         BatchCompile  -> return ()
 819         JustTypecheck -> return ()
 820 #ifdef GHCI
 821         Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables
 822 #else
 823         Interactive -> panic "unload: no interpreter"
 824 #endif
 825         other -> panic "unload: strange mode"
 826
 827 -- -----------------------------------------------------------------------------
 828 -- checkStability
 829
 830 {-
 831   Stability tells us which modules definitely do not need to be recompiled.
 832   There are two main reasons for having stability:
 833
 834    - avoid doing a complete upsweep of the module graph in GHCi when
 835      modules near the bottom of the tree have not changed.
 836
 837    - to tell GHCi when it can load object code: we can only load object code
 838      for a module when we also load object code fo  all of the imports of the
 839      module.  So we need to know that we will definitely not be recompiling
 840      any of these modules, and we can use the object code.
 841
 842   NB. stability is of no importance to BatchCompile at all, only Interactive.
 843   (ToDo: what about JustTypecheck?)
 844
 845   The stability check is as follows.  Both stableObject and
 846   stableBCO are used during the upsweep phase later.
 847
 848   -------------------
 849   stable m = stableObject m || stableBCO m
 850
 851   stableObject m =
 852         all stableObject (imports m)
 853         && old linkable does not exist, or is == on-disk .o
 854         && date(on-disk .o) > date(.hs)
 855
 856   stableBCO m =
 857         all stable (imports m)
 858         && date(BCO) > date(.hs)
 859   -------------------
 860
 861   These properties embody the following ideas:
 862
 863     - if a module is stable:
 864         - if it has been compiled in a previous pass (present in HPT)
 865           then it does not need to be compiled or re-linked.
 866         - if it has not been compiled in a previous pass,
 867           then we only need to read its .hi file from disk and
 868           link it to produce a ModDetails.
 869
 870     - if a modules is not stable, we will definitely be at least
 871       re-linking, and possibly re-compiling it during the upsweep.
 872       All non-stable modules can (and should) therefore be unlinked
 873       before the upsweep.
 874
 875     - Note that objects are only considered stable if they only depend
 876       on other objects.  We can't link object code against byte code.
 877 -}
 878
 879 checkStability
 880         :: HomePackageTable             -- HPT from last compilation
 881         -> [SCC ModSummary]             -- current module graph (cyclic)
 882         -> [ModuleName]                 -- all home modules
 883         -> ([ModuleName],               -- stableObject
 884             [ModuleName])               -- stableBCO
 885
 886 checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
 887   where
 888    checkSCC (stable_obj, stable_bco) scc0
 889      | stableObjects = (scc_mods ++ stable_obj, stable_bco)
 890      | stableBCOs    = (stable_obj, scc_mods ++ stable_bco)
 891      | otherwise     = (stable_obj, stable_bco)
 892      where
 893         scc = flattenSCC scc0
 894         scc_mods = map ms_mod_name scc
 895         home_module m   = m `elem` all_home_mods && m `notElem` scc_mods
 896
 897         scc_allimps = nub (filter home_module (concatMap ms_allimps scc))
 898             -- all imports outside the current SCC, but in the home pkg
 899
 900         stable_obj_imps = map (`elem` stable_obj) scc_allimps
 901         stable_bco_imps = map (`elem` stable_bco) scc_allimps
 902
 903         stableObjects =
 904            and stable_obj_imps
 905            && all object_ok scc
 906
 907         stableBCOs =
 908            and (zipWith (||) stable_obj_imps stable_bco_imps)
 909            && all bco_ok scc
 910
 911         object_ok ms
 912           | Just t <- ms_obj_date ms  =  t >= ms_hs_date ms
 913                                          && same_as_prev t
 914           | otherwise = False
 915           where
 916              same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of
 917                                 Just hmi  | Just l <- hm_linkable hmi
 918                                  -> isObjectLinkable l && t == linkableTime l
 919                                 _other  -> True
 920                 -- why '>=' rather than '>' above?  If the filesystem stores
 921                 -- times to the nearset second, we may occasionally find that
 922                 -- the object & source have the same modification time,
 923                 -- especially if the source was automatically generated
 924                 -- and compiled.  Using >= is slightly unsafe, but it matches
 925                 -- make's behaviour.
 926
 927         bco_ok ms
 928           = case lookupUFM hpt (ms_mod_name ms) of
 929                 Just hmi  | Just l <- hm_linkable hmi ->
 930                         not (isObjectLinkable l) &&
 931                         linkableTime l >= ms_hs_date ms
 932                 _other  -> False
 933
 934 ms_allimps :: ModSummary -> [ModuleName]
 935 ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms)
 936
 937 -- -----------------------------------------------------------------------------
 938 -- Prune the HomePackageTable
 939
 940 -- Before doing an upsweep, we can throw away:
 941 --
 942 --   - For non-stable modules:
 943 --      - all ModDetails, all linked code
 944 --   - all unlinked code that is out of date with respect to
 945 --     the source file
 946 --
 947 -- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
 948 -- space at the end of the upsweep, because the topmost ModDetails of the
 949 -- old HPT holds on to the entire type environment from the previous
 950 -- compilation.
 951
 952 pruneHomePackageTable
 953    :: HomePackageTable
 954    -> [ModSummary]
 955    -> ([ModuleName],[ModuleName])
 956    -> HomePackageTable
 957
 958 pruneHomePackageTable hpt summ (stable_obj, stable_bco)
 959   = mapUFM prune hpt
 960   where prune hmi
 961           | is_stable modl = hmi'
 962           | otherwise      = hmi'{ hm_details = emptyModDetails }
 963           where
 964            modl = moduleName (mi_module (hm_iface hmi))
 965            hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
 966                 = hmi{ hm_linkable = Nothing }
 967                 | otherwise
 968                 = hmi
 969                 where ms = expectJust "prune" (lookupUFM ms_map modl)
 970
 971         ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
 972
 973         is_stable m = m `elem` stable_obj || m `elem` stable_bco
 974
 975 -- -----------------------------------------------------------------------------
 976
 977 -- Return (names of) all those in modsDone who are part of a cycle
 978 -- as defined by theGraph.
 979 findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]
 980 findPartiallyCompletedCycles modsDone theGraph
 981    = chew theGraph
 982      where
 983         chew [] = []
 984         chew ((AcyclicSCC v):rest) = chew rest    -- acyclic?  not interesting.
 985         chew ((CyclicSCC vs):rest)
 986            = let names_in_this_cycle = nub (map ms_mod vs)
 987                  mods_in_this_cycle
 988                     = nub ([done | done <- modsDone,
 989                                    done `elem` names_in_this_cycle])
 990                  chewed_rest = chew rest
 991              in
 992              if   notNull mods_in_this_cycle
 993                   && length mods_in_this_cycle < length names_in_this_cycle
 994              then mods_in_this_cycle ++ chewed_rest
 995              else chewed_rest
 996
 997 -- -----------------------------------------------------------------------------
 998 -- The upsweep
 999
1000 -- This is where we compile each module in the module graph, in a pass
1001 -- from the bottom to the top of the graph.
1002
1003 -- There better had not be any cyclic groups here -- we check for them.
1004
1005 upsweep
1006     :: HscEnv                   -- Includes initially-empty HPT
1007     -> HomePackageTable         -- HPT from last time round (pruned)
1008     -> ([ModuleName],[ModuleName]) -- stable modules (see checkStability)
1009     -> IO ()                    -- How to clean up unwanted tmp files
1010     -> [SCC ModSummary]         -- Mods to do (the worklist)
1011     -> IO (SuccessFlag,
1012            HscEnv,              -- With an updated HPT
1013            [ModSummary])        -- Mods which succeeded
1014
1015 upsweep hsc_env old_hpt stable_mods cleanup mods
1016    = upsweep' hsc_env old_hpt stable_mods cleanup mods 1 (length mods)
1017
1018 upsweep' hsc_env old_hpt stable_mods cleanup
1019      [] _ _
1020    = return (Succeeded, hsc_env, [])
1021
1022 upsweep' hsc_env old_hpt stable_mods cleanup
1023      (CyclicSCC ms:_) _ _
1024    = do fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms)
1025         return (Failed, hsc_env, [])
1026
1027 upsweep' hsc_env old_hpt stable_mods cleanup
1028      (AcyclicSCC mod:mods) mod_index nmods
1029    = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
1030         --           show (map (moduleUserString.moduleName.mi_module.hm_iface)
1031         --                     (moduleEnvElts (hsc_HPT hsc_env)))
1032
1033         mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods mod
1034                        mod_index nmods
1035
1036         cleanup         -- Remove unwanted tmp files between compilations
1037
1038         case mb_mod_info of
1039             Nothing -> return (Failed, hsc_env, [])
1040             Just mod_info -> do
1041                 { let this_mod = ms_mod_name mod
1042
1043                         -- Add new info to hsc_env
1044                       hpt1     = addToUFM (hsc_HPT hsc_env) this_mod mod_info
1045                       hsc_env1 = hsc_env { hsc_HPT = hpt1 }
1046
1047                         -- Space-saving: delete the old HPT entry
1048                         -- for mod BUT if mod is a hs-boot
1049                         -- node, don't delete it.  For the
1050                         -- interface, the HPT entry is probaby for the
1051                         -- main Haskell source file.  Deleting it
1052                         -- would force .. (what?? --SDM)
1053                       old_hpt1 | isBootSummary mod = old_hpt
1054                                | otherwise = delFromUFM old_hpt this_mod
1055
1056                 ; (restOK, hsc_env2, modOKs)
1057                         <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup
1058                                 mods (mod_index+1) nmods
1059                 ; return (restOK, hsc_env2, mod:modOKs)
1060                 }
1061
1062
1063 -- Compile a single module.  Always produce a Linkable for it if
1064 -- successful.  If no compilation happened, return the old Linkable.
1065 upsweep_mod :: HscEnv
1066             -> HomePackageTable
1067             -> ([ModuleName],[ModuleName])
1068             -> ModSummary
1069             -> Int  -- index of module
1070             -> Int  -- total number of modules
1071             -> IO (Maybe HomeModInfo)   -- Nothing => Failed
1072
1073 upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
1074    = do
1075         let
1076             this_mod_name = ms_mod_name summary
1077             this_mod    = ms_mod summary
1078             mb_obj_date = ms_obj_date summary
1079             obj_fn      = ml_obj_file (ms_location summary)
1080             hs_date     = ms_hs_date summary
1081
1082             compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
1083             compile_it  = upsweep_compile hsc_env old_hpt this_mod_name
1084                                 summary mod_index nmods
1085
1086         case ghcMode (hsc_dflags hsc_env) of
1087             BatchCompile ->
1088                 case () of
1089                    -- Batch-compilating is easy: just check whether we have
1090                    -- an up-to-date object file.  If we do, then the compiler
1091                    -- needs to do a recompilation check.
1092                    _ | Just obj_date <- mb_obj_date, obj_date >= hs_date -> do
1093                            linkable <-
1094                                 findObjectLinkable this_mod obj_fn obj_date
1095                            compile_it (Just linkable)
1096
1097                      | otherwise ->
1098                            compile_it Nothing
1099
1100             interactive ->
1101                 case () of
1102                     _ | is_stable_obj, isJust old_hmi ->
1103                            return old_hmi
1104                         -- object is stable, and we have an entry in the
1105                         -- old HPT: nothing to do
1106
1107                       | is_stable_obj, isNothing old_hmi -> do
1108                            linkable <-
1109                                 findObjectLinkable this_mod obj_fn
1110                                         (expectJust "upseep1" mb_obj_date)
1111                            compile_it (Just linkable)
1112                         -- object is stable, but we need to load the interface
1113                         -- off disk to make a HMI.
1114
1115                       | is_stable_bco ->
1116                            ASSERT(isJust old_hmi) -- must be in the old_hpt
1117                            return old_hmi
1118                         -- BCO is stable: nothing to do
1119
1120                       | Just hmi <- old_hmi,
1121                         Just l <- hm_linkable hmi, not (isObjectLinkable l),
1122                         linkableTime l >= ms_hs_date summary ->
1123                            compile_it (Just l)
1124                         -- we have an old BCO that is up to date with respect
1125                         -- to the source: do a recompilation check as normal.
1126
1127                       | otherwise ->
1128                           compile_it Nothing
1129                         -- no existing code at all: we must recompile.
1130                    where
1131                     is_stable_obj = this_mod_name `elem` stable_obj
1132                     is_stable_bco = this_mod_name `elem` stable_bco
1133
1134                     old_hmi = lookupUFM old_hpt this_mod_name
1135
1136 -- Run hsc to compile a module
1137 upsweep_compile hsc_env old_hpt this_mod summary
1138                 mod_index nmods
1139                 mb_old_linkable = do
1140   let
1141         -- The old interface is ok if it's in the old HPT
1142         --      a) we're compiling a source file, and the old HPT
1143         --         entry is for a source file
1144         --      b) we're compiling a hs-boot file
1145         -- Case (b) allows an hs-boot file to get the interface of its
1146         -- real source file on the second iteration of the compilation
1147         -- manager, but that does no harm.  Otherwise the hs-boot file
1148         -- will always be recompiled
1149
1150         mb_old_iface
1151                 = case lookupUFM old_hpt this_mod of
1152                      Nothing                              -> Nothing
1153                      Just hm_info | isBootSummary summary -> Just iface
1154                                   | not (mi_boot iface)   -> Just iface
1155                                   | otherwise             -> Nothing
1156                                    where
1157                                      iface = hm_iface hm_info
1158
1159   compresult <- compile hsc_env summary mb_old_linkable mb_old_iface
1160                         mod_index nmods
1161
1162   case compresult of
1163         -- Compilation failed.  Compile may still have updated the PCS, tho.
1164         CompErrs -> return Nothing
1165
1166         -- Compilation "succeeded", and may or may not have returned a new
1167         -- linkable (depending on whether compilation was actually performed
1168         -- or not).
1169         CompOK new_details new_iface new_linkable
1170               -> do let new_info = HomeModInfo { hm_iface = new_iface,
1171                                                  hm_details = new_details,
1172                                                  hm_linkable = new_linkable }
1173                     return (Just new_info)
1174
1175
1176 -- Filter modules in the HPT
1177 retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
1178 retainInTopLevelEnvs keep_these hpt
1179    = listToUFM   [ (mod, expectJust "retain" mb_mod_info)
1180                  | mod <- keep_these
1181                  , let mb_mod_info = lookupUFM hpt mod
1182                  , isJust mb_mod_info ]
1183
1184 -- ---------------------------------------------------------------------------
1185 -- Topological sort of the module graph
1186
1187 topSortModuleGraph
1188           :: Bool               -- Drop hi-boot nodes? (see below)
1189           -> [ModSummary]
1190           -> Maybe ModuleName
1191           -> [SCC ModSummary]
1192 -- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
1193 -- The resulting list of strongly-connected-components is in topologically
1194 -- sorted order, starting with the module(s) at the bottom of the
1195 -- dependency graph (ie compile them first) and ending with the ones at
1196 -- the top.
1197 --
1198 -- Drop hi-boot nodes (first boolean arg)?
1199 --
1200 --   False:     treat the hi-boot summaries as nodes of the graph,
1201 --              so the graph must be acyclic
1202 --
1203 --   True:      eliminate the hi-boot nodes, and instead pretend
1204 --              the a source-import of Foo is an import of Foo
1205 --              The resulting graph has no hi-boot nodes, but can by cyclic
1206
1207 topSortModuleGraph drop_hs_boot_nodes summaries Nothing
1208   = stronglyConnComp (fst (moduleGraphNodes drop_hs_boot_nodes summaries))
1209 topSortModuleGraph drop_hs_boot_nodes summaries (Just mod)
1210   = stronglyConnComp (map vertex_fn (reachable graph root))
1211   where
1212         -- restrict the graph to just those modules reachable from
1213         -- the specified module.  We do this by building a graph with
1214         -- the full set of nodes, and determining the reachable set from
1215         -- the specified node.
1216         (nodes, lookup_key) = moduleGraphNodes drop_hs_boot_nodes summaries
1217         (graph, vertex_fn, key_fn) = graphFromEdges' nodes
1218         root
1219           | Just key <- lookup_key HsSrcFile mod, Just v <- key_fn key = v
1220           | otherwise  = throwDyn (ProgramError "module does not exist")
1221
1222 moduleGraphNodes :: Bool -> [ModSummary]
1223   -> ([(ModSummary, Int, [Int])], HscSource -> ModuleName -> Maybe Int)
1224 moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key)
1225    where
1226         -- Drop hs-boot nodes by using HsSrcFile as the key
1227         hs_boot_key | drop_hs_boot_nodes = HsSrcFile
1228                     | otherwise          = HsBootFile
1229
1230         -- We use integers as the keys for the SCC algorithm
1231         nodes :: [(ModSummary, Int, [Int])]
1232         nodes = [(s, expectJust "topSort" (lookup_key (ms_hsc_src s) (ms_mod_name s)),
1233                      out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++
1234                      out_edge_keys HsSrcFile   (map unLoc (ms_imps s))    )
1235                 | s <- summaries
1236                 , not (isBootSummary s && drop_hs_boot_nodes) ]
1237                 -- Drop the hi-boot ones if told to do so
1238
1239         key_map :: NodeMap Int
1240         key_map = listToFM ([(moduleName (ms_mod s), ms_hsc_src s)
1241                             | s <- summaries]
1242                            `zip` [1..])
1243
1244         lookup_key :: HscSource -> ModuleName -> Maybe Int
1245         lookup_key hs_src mod = lookupFM key_map (mod, hs_src)
1246
1247         out_edge_keys :: HscSource -> [ModuleName] -> [Int]
1248         out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
1249                 -- If we want keep_hi_boot_nodes, then we do lookup_key with
1250                 -- the IsBootInterface parameter True; else False
1251
1252
1253 type NodeKey   = (ModuleName, HscSource)  -- The nodes of the graph are
1254 type NodeMap a = FiniteMap NodeKey a      -- keyed by (mod, src_file_type) pairs
1255
1256 msKey :: ModSummary -> NodeKey
1257 msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
1258
1259 mkNodeMap :: [ModSummary] -> NodeMap ModSummary
1260 mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
1261
1262 nodeMapElts :: NodeMap a -> [a]
1263 nodeMapElts = eltsFM
1264
1265 ms_mod_name :: ModSummary -> ModuleName
1266 ms_mod_name = moduleName . ms_mod
1267
1268 -----------------------------------------------------------------------------
1269 -- Downsweep (dependency analysis)
1270
1271 -- Chase downwards from the specified root set, returning summaries
1272 -- for all home modules encountered.  Only follow source-import
1273 -- links.
1274
1275 -- We pass in the previous collection of summaries, which is used as a
1276 -- cache to avoid recalculating a module summary if the source is
1277 -- unchanged.
1278 --
1279 -- The returned list of [ModSummary] nodes has one node for each home-package
1280 -- module, plus one for any hs-boot files.  The imports of these nodes
1281 -- are all there, including the imports of non-home-package modules.
1282
1283 downsweep :: HscEnv
1284           -> [ModSummary]       -- Old summaries
1285           -> [ModuleName]       -- Ignore dependencies on these; treat
1286                                 -- them as if they were package modules
1287           -> Bool               -- True <=> allow multiple targets to have
1288                                 --          the same module name; this is
1289                                 --          very useful for ghc -M
1290           -> IO (Maybe [ModSummary])
1291                 -- The elts of [ModSummary] all have distinct
1292                 -- (Modules, IsBoot) identifiers, unless the Bool is true
1293                 -- in which case there can be repeats
1294 downsweep hsc_env old_summaries excl_mods allow_dup_roots
1295    = -- catch error messages and return them
1296      handleDyn (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
1297        rootSummaries <- mapM getRootSummary roots
1298        let root_map = mkRootMap rootSummaries
1299        checkDuplicates root_map
1300        summs <- loop (concatMap msDeps rootSummaries) root_map
1301        return (Just summs)
1302      where
1303         roots = hsc_targets hsc_env
1304
1305         old_summary_map :: NodeMap ModSummary
1306         old_summary_map = mkNodeMap old_summaries
1307
1308         getRootSummary :: Target -> IO ModSummary
1309         getRootSummary (Target (TargetFile file mb_phase) maybe_buf)
1310            = do exists <- doesFileExist file
1311                 if exists
1312                     then summariseFile hsc_env old_summaries file mb_phase maybe_buf
1313                     else throwDyn $ mkPlainErrMsg noSrcSpan $
1314                            text "can't find file:" <+> text file
1315         getRootSummary (Target (TargetModule modl) maybe_buf)
1316            = do maybe_summary <- summariseModule hsc_env old_summary_map False
1317                                            (L rootLoc modl) maybe_buf excl_mods
1318                 case maybe_summary of
1319                    Nothing -> packageModErr modl
1320                    Just s  -> return s
1321
1322         rootLoc = mkGeneralSrcSpan FSLIT("<command line>")
1323
1324         -- In a root module, the filename is allowed to diverge from the module
1325         -- name, so we have to check that there aren't multiple root files
1326         -- defining the same module (otherwise the duplicates will be silently
1327         -- ignored, leading to confusing behaviour).
1328         checkDuplicates :: NodeMap [ModSummary] -> IO ()
1329         checkDuplicates root_map
1330            | allow_dup_roots = return ()
1331            | null dup_roots  = return ()
1332            | otherwise       = multiRootsErr (head dup_roots)
1333            where
1334              dup_roots :: [[ModSummary]]        -- Each at least of length 2
1335              dup_roots = filterOut isSingleton (nodeMapElts root_map)
1336
1337         loop :: [(Located ModuleName,IsBootInterface)]
1338                         -- Work list: process these modules
1339              -> NodeMap [ModSummary]
1340                         -- Visited set; the range is a list because
1341                         -- the roots can have the same module names
1342                         -- if allow_dup_roots is True
1343              -> IO [ModSummary]
1344                         -- The result includes the worklist, except
1345                         -- for those mentioned in the visited set
1346         loop [] done      = return (concat (nodeMapElts done))
1347         loop ((wanted_mod, is_boot) : ss) done
1348           | Just summs <- lookupFM done key
1349           = if isSingleton summs then
1350                 loop ss done
1351             else
1352                 do { multiRootsErr summs; return [] }
1353           | otherwise         = do { mb_s <- summariseModule hsc_env old_summary_map
1354                                                  is_boot wanted_mod Nothing excl_mods
1355                                    ; case mb_s of
1356                                         Nothing -> loop ss done
1357                                         Just s  -> loop (msDeps s ++ ss)
1358                                                         (addToFM done key [s]) }
1359           where
1360             key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
1361
1362 mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
1363 mkRootMap summaries = addListToFM_C (++) emptyFM
1364                         [ (msKey s, [s]) | s <- summaries ]
1365
1366 msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
1367 -- (msDeps s) returns the dependencies of the ModSummary s.
1368 -- A wrinkle is that for a {-# SOURCE #-} import we return
1369 --      *both* the hs-boot file
1370 --      *and* the source file
1371 -- as "dependencies".  That ensures that the list of all relevant
1372 -- modules always contains B.hs if it contains B.hs-boot.
1373 -- Remember, this pass isn't doing the topological sort.  It's
1374 -- just gathering the list of all relevant ModSummaries
1375 msDeps s =
1376     concat [ [(m,True), (m,False)] | m <- ms_srcimps s ]
1377          ++ [ (m,False) | m <- ms_imps s ]
1378
1379 -----------------------------------------------------------------------------
1380 -- Summarising modules
1381
1382 -- We have two types of summarisation:
1383 --
1384 --    * Summarise a file.  This is used for the root module(s) passed to
1385 --      cmLoadModules.  The file is read, and used to determine the root
1386 --      module name.  The module name may differ from the filename.
1387 --
1388 --    * Summarise a module.  We are given a module name, and must provide
1389 --      a summary.  The finder is used to locate the file in which the module
1390 --      resides.
1391
1392 summariseFile
1393         :: HscEnv
1394         -> [ModSummary]                 -- old summaries
1395         -> FilePath                     -- source file name
1396         -> Maybe Phase                  -- start phase
1397         -> Maybe (StringBuffer,ClockTime)
1398         -> IO ModSummary
1399
1400 summariseFile hsc_env old_summaries file mb_phase maybe_buf
1401         -- we can use a cached summary if one is available and the
1402         -- source file hasn't changed,  But we have to look up the summary
1403         -- by source file, rather than module name as we do in summarise.
1404    | Just old_summary <- findSummaryBySourceFile old_summaries file
1405    = do
1406         let location = ms_location old_summary
1407
1408                 -- return the cached summary if the source didn't change
1409         src_timestamp <- case maybe_buf of
1410                            Just (_,t) -> return t
1411                            Nothing    -> getModificationTime file
1412                 -- The file exists; we checked in getRootSummary above.
1413                 -- If it gets removed subsequently, then this
1414                 -- getModificationTime may fail, but that's the right
1415                 -- behaviour.
1416
1417         if ms_hs_date old_summary == src_timestamp
1418            then do -- update the object-file timestamp
1419                   obj_timestamp <- getObjTimestamp location False
1420                   return old_summary{ ms_obj_date = obj_timestamp }
1421            else
1422                 new_summary
1423
1424    | otherwise
1425    = new_summary
1426   where
1427     new_summary = do
1428         let dflags = hsc_dflags hsc_env
1429
1430         (dflags', hspp_fn, buf)
1431             <- preprocessFile dflags file mb_phase maybe_buf
1432
1433         (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn
1434
1435         -- Make a ModLocation for this file
1436         location <- mkHomeModLocation dflags mod_name file
1437
1438         -- Tell the Finder cache where it is, so that subsequent calls
1439         -- to findModule will find it, even if it's not on any search path
1440         mod <- addHomeModuleToFinder hsc_env mod_name location
1441
1442         src_timestamp <- case maybe_buf of
1443                            Just (_,t) -> return t
1444                            Nothing    -> getModificationTime file
1445                         -- getMofificationTime may fail
1446
1447         obj_timestamp <- modificationTimeIfExists (ml_obj_file location)
1448
1449         return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
1450                              ms_location = location,
1451                              ms_hspp_file = hspp_fn,
1452                              ms_hspp_opts = dflags',
1453                              ms_hspp_buf  = Just buf,
1454                              ms_srcimps = srcimps, ms_imps = the_imps,
1455                              ms_hs_date = src_timestamp,
1456                              ms_obj_date = obj_timestamp })
1457
1458 findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
1459 findSummaryBySourceFile summaries file
1460   = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
1461                                  expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
1462         [] -> Nothing
1463         (x:xs) -> Just x
1464
1465 -- Summarise a module, and pick up source and timestamp.
1466 summariseModule
1467           :: HscEnv
1468           -> NodeMap ModSummary -- Map of old summaries
1469           -> IsBootInterface    -- True <=> a {-# SOURCE #-} import
1470           -> Located ModuleName -- Imported module to be summarised
1471           -> Maybe (StringBuffer, ClockTime)
1472           -> [ModuleName]               -- Modules to exclude
1473           -> IO (Maybe ModSummary)      -- Its new summary
1474
1475 summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf excl_mods
1476   | wanted_mod `elem` excl_mods
1477   = return Nothing
1478
1479   | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src)
1480   = do          -- Find its new timestamp; all the
1481                 -- ModSummaries in the old map have valid ml_hs_files
1482         let location = ms_location old_summary
1483             src_fn = expectJust "summariseModule" (ml_hs_file location)
1484
1485                 -- check the modification time on the source file, and
1486                 -- return the cached summary if it hasn't changed.  If the
1487                 -- file has disappeared, we need to call the Finder again.
1488         case maybe_buf of
1489            Just (_,t) -> check_timestamp old_summary location src_fn t
1490            Nothing    -> do
1491                 m <- System.IO.Error.try (getModificationTime src_fn)
1492                 case m of
1493                    Right t -> check_timestamp old_summary location src_fn t
1494                    Left e | isDoesNotExistError e -> find_it
1495                           | otherwise             -> ioError e
1496
1497   | otherwise  = find_it
1498   where
1499     dflags = hsc_dflags hsc_env
1500
1501     hsc_src = if is_boot then HsBootFile else HsSrcFile
1502
1503     check_timestamp old_summary location src_fn src_timestamp
1504         | ms_hs_date old_summary == src_timestamp = do
1505                 -- update the object-file timestamp
1506                 obj_timestamp <- getObjTimestamp location is_boot
1507                 return (Just old_summary{ ms_obj_date = obj_timestamp })
1508         | otherwise =
1509                 -- source changed: re-summarise.
1510                 new_summary location (ms_mod old_summary) src_fn src_timestamp
1511
1512     find_it = do
1513         -- Don't use the Finder's cache this time.  If the module was
1514         -- previously a package module, it may have now appeared on the
1515         -- search path, so we want to consider it to be a home module.  If
1516         -- the module was previously a home module, it may have moved.
1517         uncacheModule hsc_env wanted_mod
1518         found <- findImportedModule hsc_env wanted_mod Nothing
1519         case found of
1520              Found location mod
1521                 | isJust (ml_hs_file location) ->
1522                         -- Home package
1523                          just_found location mod
1524                 | otherwise ->
1525                         -- Drop external-pkg
1526                         ASSERT(modulePackageId mod /= thisPackage dflags)
1527                         return Nothing
1528                 where
1529
1530              err -> noModError dflags loc wanted_mod err
1531                         -- Not found
1532
1533     just_found location mod = do
1534                 -- Adjust location to point to the hs-boot source file,
1535                 -- hi file, object file, when is_boot says so
1536         let location' | is_boot   = addBootSuffixLocn location
1537                       | otherwise = location
1538             src_fn = expectJust "summarise2" (ml_hs_file location')
1539
1540                 -- Check that it exists
1541                 -- It might have been deleted since the Finder last found it
1542         maybe_t <- modificationTimeIfExists src_fn
1543         case maybe_t of
1544           Nothing -> noHsFileErr loc src_fn
1545           Just t  -> new_summary location' mod src_fn t
1546
1547
1548     new_summary location mod src_fn src_timestamp
1549       = do
1550         -- Preprocess the source file and get its imports
1551         -- The dflags' contains the OPTIONS pragmas
1552         (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf
1553         (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn
1554
1555         when (mod_name /= wanted_mod) $
1556                 throwDyn $ mkPlainErrMsg mod_loc $
1557                               text "file name does not match module name"
1558                               <+> quotes (ppr mod_name)
1559
1560                 -- Find the object timestamp, and return the summary
1561         obj_timestamp <- getObjTimestamp location is_boot
1562
1563         return (Just ( ModSummary { ms_mod       = mod,
1564                                     ms_hsc_src   = hsc_src,
1565                                     ms_location  = location,
1566                                     ms_hspp_file = hspp_fn,
1567                                     ms_hspp_opts = dflags',
1568                                     ms_hspp_buf  = Just buf,
1569                                     ms_srcimps   = srcimps,
1570                                     ms_imps      = the_imps,
1571                                     ms_hs_date   = src_timestamp,
1572                                     ms_obj_date  = obj_timestamp }))
1573
1574
1575 getObjTimestamp location is_boot
1576   = if is_boot then return Nothing
1577                else modificationTimeIfExists (ml_obj_file location)
1578
1579
1580 preprocessFile :: DynFlags -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime)
1581   -> IO (DynFlags, FilePath, StringBuffer)
1582 preprocessFile dflags src_fn mb_phase Nothing
1583   = do
1584         (dflags', hspp_fn) <- preprocess dflags (src_fn, mb_phase)
1585         buf <- hGetStringBuffer hspp_fn
1586         return (dflags', hspp_fn, buf)
1587
1588 preprocessFile dflags src_fn mb_phase (Just (buf, time))
1589   = do
1590         -- case we bypass the preprocessing stage?
1591         let
1592             local_opts = getOptions buf src_fn
1593         --
1594         (dflags', errs) <- parseDynamicFlags dflags (map unLoc local_opts)
1595
1596         let
1597             needs_preprocessing
1598                 | Just (Unlit _) <- mb_phase    = True
1599                 | Nothing <- mb_phase, Unlit _ <- startPhase src_fn  = True
1600                   -- note: local_opts is only required if there's no Unlit phase
1601                 | dopt Opt_Cpp dflags'          = True
1602                 | dopt Opt_Pp  dflags'          = True
1603                 | otherwise                     = False
1604
1605         when needs_preprocessing $
1606            ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
1607
1608         return (dflags', src_fn, buf)
1609
1610
1611 -----------------------------------------------------------------------------
1612 --                      Error messages
1613 -----------------------------------------------------------------------------
1614
1615 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
1616 -- ToDo: we don't have a proper line number for this error
1617 noModError dflags loc wanted_mod err
1618   = throwDyn $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
1619
1620 noHsFileErr loc path
1621   = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path
1622
1623 packageModErr mod
1624   = throwDyn $ mkPlainErrMsg noSrcSpan $
1625         text "module" <+> quotes (ppr mod) <+> text "is a package module"
1626
1627 multiRootsErr :: [ModSummary] -> IO ()
1628 multiRootsErr summs@(summ1:_)
1629   = throwDyn $ mkPlainErrMsg noSrcSpan $
1630         text "module" <+> quotes (ppr mod) <+>
1631         text "is defined in multiple files:" <+>
1632         sep (map text files)
1633   where
1634     mod = ms_mod summ1
1635     files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
1636
1637 cyclicModuleErr :: [ModSummary] -> SDoc
1638 cyclicModuleErr ms
1639   = hang (ptext SLIT("Module imports form a cycle for modules:"))
1640        2 (vcat (map show_one ms))
1641   where
1642     show_one ms = sep [ show_mod (ms_hsc_src ms) (ms_mod ms),
1643                         nest 2 $ ptext SLIT("imports:") <+>
1644                                    (pp_imps HsBootFile (ms_srcimps ms)
1645                                    $$ pp_imps HsSrcFile  (ms_imps ms))]
1646     show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
1647     pp_imps src mods = fsep (map (show_mod src) mods)
1648
1649
1650 -- | Inform GHC that the working directory has changed.  GHC will flush
1651 -- its cache of module locations, since it may no longer be valid.
1652 -- Note: if you change the working directory, you should also unload
1653 -- the current program (set targets to empty, followed by load).
1654 workingDirectoryChanged :: Session -> IO ()
1655 workingDirectoryChanged s = withSession s $ flushFinderCaches
1656
1657 -- -----------------------------------------------------------------------------
1658 -- inspecting the session
1659
1660 -- | Get the module dependency graph.
1661 getModuleGraph :: Session -> IO ModuleGraph -- ToDo: DiGraph ModSummary
1662 getModuleGraph s = withSession s (return . hsc_mod_graph)
1663
1664 isLoaded :: Session -> ModuleName -> IO Bool
1665 isLoaded s m = withSession s $ \hsc_env ->
1666   return $! isJust (lookupUFM (hsc_HPT hsc_env) m)
1667
1668 getBindings :: Session -> IO [TyThing]
1669 getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC)
1670
1671 getPrintUnqual :: Session -> IO PrintUnqualified
1672 getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC)
1673
1674 -- | Container for information about a 'Module'.
1675 data ModuleInfo = ModuleInfo {
1676         minf_type_env  :: TypeEnv,
1677         minf_exports   :: NameSet,
1678         minf_rdr_env   :: Maybe GlobalRdrEnv,   -- Nothing for a compiled/package mod
1679         minf_instances :: [Instance]
1680         -- ToDo: this should really contain the ModIface too
1681   }
1682         -- We don't want HomeModInfo here, because a ModuleInfo applies
1683         -- to package modules too.
1684
1685 -- | Request information about a loaded 'Module'
1686 getModuleInfo :: Session -> Module -> IO (Maybe ModuleInfo)
1687 getModuleInfo s mdl = withSession s $ \hsc_env -> do
1688   let mg = hsc_mod_graph hsc_env
1689   if mdl `elem` map ms_mod mg
1690         then getHomeModuleInfo hsc_env (moduleName mdl)
1691         else do
1692   {- if isHomeModule (hsc_dflags hsc_env) mdl
1693         then return Nothing
1694         else -} getPackageModuleInfo hsc_env mdl
1695    -- getPackageModuleInfo will attempt to find the interface, so
1696    -- we don't want to call it for a home module, just in case there
1697    -- was a problem loading the module and the interface doesn't
1698    -- exist... hence the isHomeModule test here.  (ToDo: reinstate)
1699
1700 getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
1701 getPackageModuleInfo hsc_env mdl = do
1702 #ifdef GHCI
1703   (_msgs, mb_names) <- getModuleExports hsc_env mdl
1704   case mb_names of
1705     Nothing -> return Nothing
1706     Just names -> do
1707         eps <- readIORef (hsc_EPS hsc_env)
1708         let
1709             pte    = eps_PTE eps
1710             n_list = nameSetToList names
1711             tys    = [ ty | name <- n_list,
1712                             Just ty <- [lookupTypeEnv pte name] ]
1713         --
1714         return (Just (ModuleInfo {
1715                         minf_type_env  = mkTypeEnv tys,
1716                         minf_exports   = names,
1717                         minf_rdr_env   = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),
1718                         minf_instances = error "getModuleInfo: instances for package module unimplemented"
1719                 }))
1720 #else
1721   -- bogusly different for non-GHCI (ToDo)
1722   return Nothing
1723 #endif
1724
1725 getHomeModuleInfo hsc_env mdl =
1726   case lookupUFM (hsc_HPT hsc_env) mdl of
1727     Nothing  -> return Nothing
1728     Just hmi -> do
1729       let details = hm_details hmi
1730       return (Just (ModuleInfo {
1731                         minf_type_env  = md_types details,
1732                         minf_exports   = md_exports details,
1733                         minf_rdr_env   = mi_globals $! hm_iface hmi,
1734                         minf_instances = md_insts details
1735                         }))
1736
1737 -- | The list of top-level entities defined in a module
1738 modInfoTyThings :: ModuleInfo -> [TyThing]
1739 modInfoTyThings minf = typeEnvElts (minf_type_env minf)
1740
1741 modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
1742 modInfoTopLevelScope minf
1743   = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
1744
1745 modInfoExports :: ModuleInfo -> [Name]
1746 modInfoExports minf = nameSetToList $! minf_exports minf
1747
1748 -- | Returns the instances defined by the specified module.
1749 -- Warning: currently unimplemented for package modules.
1750 modInfoInstances :: ModuleInfo -> [Instance]
1751 modInfoInstances = minf_instances
1752
1753 modInfoIsExportedName :: ModuleInfo -> Name -> Bool
1754 modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
1755
1756 modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified
1757 modInfoPrintUnqualified minf = fmap mkPrintUnqualified (minf_rdr_env minf)
1758
1759 modInfoLookupName :: Session -> ModuleInfo -> Name -> IO (Maybe TyThing)
1760 modInfoLookupName s minf name = withSession s $ \hsc_env -> do
1761    case lookupTypeEnv (minf_type_env minf) name of
1762      Just tyThing -> return (Just tyThing)
1763      Nothing      -> do
1764        eps <- readIORef (hsc_EPS hsc_env)
1765        return $! lookupType (hsc_dflags hsc_env)
1766                             (hsc_HPT hsc_env) (eps_PTE eps) name
1767
1768 isDictonaryId :: Id -> Bool
1769 isDictonaryId id
1770   = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau }
1771
1772 -- | Looks up a global name: that is, any top-level name in any
1773 -- visible module.  Unlike 'lookupName', lookupGlobalName does not use
1774 -- the interactive context, and therefore does not require a preceding
1775 -- 'setContext'.
1776 lookupGlobalName :: Session -> Name -> IO (Maybe TyThing)
1777 lookupGlobalName s name = withSession s $ \hsc_env -> do
1778    eps <- readIORef (hsc_EPS hsc_env)
1779    return $! lookupType (hsc_dflags hsc_env)
1780                         (hsc_HPT hsc_env) (eps_PTE eps) name
1781
1782 -- -----------------------------------------------------------------------------
1783 -- Misc exported utils
1784
1785 dataConType :: DataCon -> Type
1786 dataConType dc = idType (dataConWrapId dc)
1787
1788 -- | print a 'NamedThing', adding parentheses if the name is an operator.
1789 pprParenSymName :: NamedThing a => a -> SDoc
1790 pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
1791
1792 -- ----------------------------------------------------------------------------
1793
1794 #if 0
1795
1796 -- ToDo:
1797 --   - Data and Typeable instances for HsSyn.
1798
1799 -- ToDo: check for small transformations that happen to the syntax in
1800 -- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
1801
1802 -- ToDo: maybe use TH syntax instead of IfaceSyn?  There's already a way
1803 -- to get from TyCons, Ids etc. to TH syntax (reify).
1804
1805 -- :browse will use either lm_toplev or inspect lm_interface, depending
1806 -- on whether the module is interpreted or not.
1807
1808 -- This is for reconstructing refactored source code
1809 -- Calls the lexer repeatedly.
1810 -- ToDo: add comment tokens to token stream
1811 getTokenStream :: Session -> Module -> IO [Located Token]
1812 #endif
1813
1814 -- -----------------------------------------------------------------------------
1815 -- Interactive evaluation
1816
1817 -- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the
1818 -- filesystem and package database to find the corresponding 'Module',
1819 -- using the algorithm that is used for an @import@ declaration.
1820 findModule :: Session -> ModuleName -> Maybe PackageId -> IO Module
1821 findModule s mod_name maybe_pkg = withSession s $ \hsc_env ->
1822   findModule' hsc_env mod_name maybe_pkg
1823
1824 findModule' hsc_env mod_name maybe_pkg =
1825   let
1826         dflags = hsc_dflags hsc_env
1827         hpt    = hsc_HPT hsc_env
1828         this_pkg = thisPackage dflags
1829   in
1830   case lookupUFM hpt mod_name of
1831     Just mod_info -> return (mi_module (hm_iface mod_info))
1832     _not_a_home_module -> do
1833           res <- findImportedModule hsc_env mod_name Nothing
1834           case res of
1835             Found _ m | modulePackageId m /= this_pkg -> return m
1836                       | otherwise -> throwDyn (CmdLineError (showSDoc $
1837                                         text "module" <+> pprModule m <+>
1838                                         text "is not loaded"))
1839             err -> let msg = cannotFindModule dflags mod_name err in
1840                    throwDyn (CmdLineError (showSDoc msg))
1841
1842 #ifdef GHCI
1843
1844 -- | Set the interactive evaluation context.
1845 --
1846 -- Setting the context doesn't throw away any bindings; the bindings
1847 -- we've built up in the InteractiveContext simply move to the new
1848 -- module.  They always shadow anything in scope in the current context.
1849 setContext :: Session
1850            -> [Module]  -- entire top level scope of these modules
1851            -> [Module]  -- exports only of these modules
1852            -> IO ()
1853 setContext (Session ref) toplev_mods export_mods = do
1854   hsc_env <- readIORef ref
1855   let old_ic  = hsc_IC     hsc_env
1856       hpt     = hsc_HPT    hsc_env
1857   --
1858   export_env  <- mkExportEnv hsc_env export_mods
1859   toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
1860   let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
1861   writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
1862                                             ic_exports      = export_mods,
1863                                             ic_rn_gbl_env   = all_env }}
1864
1865
1866 -- Make a GlobalRdrEnv based on the exports of the modules only.
1867 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
1868 mkExportEnv hsc_env mods = do
1869   stuff <- mapM (getModuleExports hsc_env) mods
1870   let
1871         (_msgs, mb_name_sets) = unzip stuff
1872         gres = [ nameSetToGlobalRdrEnv name_set (moduleName mod)
1873                | (Just name_set, mod) <- zip mb_name_sets mods ]
1874   --
1875   return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
1876
1877 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
1878 nameSetToGlobalRdrEnv names mod =
1879   mkGlobalRdrEnv [ GRE  { gre_name = name, gre_prov = vanillaProv mod }
1880                  | name <- nameSetToList names ]
1881
1882 vanillaProv :: ModuleName -> Provenance
1883 -- We're building a GlobalRdrEnv as if the user imported
1884 -- all the specified modules into the global interactive module
1885 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
1886   where
1887     decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
1888                          is_qual = False,
1889                          is_dloc = srcLocSpan interactiveSrcLoc }
1890
1891 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
1892 mkTopLevEnv hpt modl
1893   = case lookupUFM hpt (moduleName modl) of
1894       Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
1895                                                 showSDoc (ppr modl)))
1896       Just details ->
1897          case mi_globals (hm_iface details) of
1898                 Nothing  ->
1899                    throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
1900                                                 ++ showSDoc (ppr modl)))
1901                 Just env -> return env
1902
1903 -- | Get the interactive evaluation context, consisting of a pair of the
1904 -- set of modules from which we take the full top-level scope, and the set
1905 -- of modules from which we take just the exports respectively.
1906 getContext :: Session -> IO ([Module],[Module])
1907 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
1908                                 return (ic_toplev_scope ic, ic_exports ic))
1909
1910 -- | Returns 'True' if the specified module is interpreted, and hence has
1911 -- its full top-level scope available.
1912 moduleIsInterpreted :: Session -> Module -> IO Bool
1913 moduleIsInterpreted s modl = withSession s $ \h ->
1914  if modulePackageId modl /= thisPackage (hsc_dflags h)
1915         then return False
1916         else case lookupUFM (hsc_HPT h) (moduleName modl) of
1917                 Just details       -> return (isJust (mi_globals (hm_iface details)))
1918                 _not_a_home_module -> return False
1919
1920 -- | Looks up an identifier in the current interactive context (for :info)
1921 getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
1922 getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name
1923
1924 -- | Returns all names in scope in the current interactive context
1925 getNamesInScope :: Session -> IO [Name]
1926 getNamesInScope s = withSession s $ \hsc_env -> do
1927   return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
1928
1929 getRdrNamesInScope :: Session -> IO [RdrName]
1930 getRdrNamesInScope  s = withSession s $ \hsc_env -> do
1931   let env = ic_rn_gbl_env (hsc_IC hsc_env)
1932   return (concat (map greToRdrNames (globalRdrEnvElts env)))
1933
1934 -- ToDo: move to RdrName
1935 greToRdrNames :: GlobalRdrElt -> [RdrName]
1936 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
1937   = case prov of
1938      LocalDef -> [unqual]
1939      Imported specs -> concat (map do_spec (map is_decl specs))
1940   where
1941     occ = nameOccName name
1942     unqual = Unqual occ
1943     do_spec decl_spec
1944         | is_qual decl_spec = [qual]
1945         | otherwise         = [unqual,qual]
1946         where qual = Qual (is_as decl_spec) occ
1947
1948 -- | Parses a string as an identifier, and returns the list of 'Name's that
1949 -- the identifier can refer to in the current interactive context.
1950 parseName :: Session -> String -> IO [Name]
1951 parseName s str = withSession s $ \hsc_env -> do
1952    maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
1953    case maybe_rdr_name of
1954         Nothing -> return []
1955         Just (L _ rdr_name) -> do
1956             mb_names <- tcRnLookupRdrName hsc_env rdr_name
1957             case mb_names of
1958                 Nothing -> return []
1959                 Just ns -> return ns
1960                 -- ToDo: should return error messages
1961
1962 -- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
1963 -- entity known to GHC, including 'Name's defined using 'runStmt'.
1964 lookupName :: Session -> Name -> IO (Maybe TyThing)
1965 lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
1966
1967 -- -----------------------------------------------------------------------------
1968 -- Getting the type of an expression
1969
1970 -- | Get the type of an expression
1971 exprType :: Session -> String -> IO (Maybe Type)
1972 exprType s expr = withSession s $ \hsc_env -> do
1973    maybe_stuff <- hscTcExpr hsc_env expr
1974    case maybe_stuff of
1975         Nothing -> return Nothing
1976         Just ty -> return (Just tidy_ty)
1977              where
1978                 tidy_ty = tidyType emptyTidyEnv ty
1979
1980 -- -----------------------------------------------------------------------------
1981 -- Getting the kind of a type
1982
1983 -- | Get the kind of a  type
1984 typeKind  :: Session -> String -> IO (Maybe Kind)
1985 typeKind s str = withSession s $ \hsc_env -> do
1986    maybe_stuff <- hscKcType hsc_env str
1987    case maybe_stuff of
1988         Nothing -> return Nothing
1989         Just kind -> return (Just kind)
1990
1991 -----------------------------------------------------------------------------
1992 -- cmCompileExpr: compile an expression and deliver an HValue
1993
1994 compileExpr :: Session -> String -> IO (Maybe HValue)
1995 compileExpr s expr = withSession s $ \hsc_env -> do
1996   maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
1997   case maybe_stuff of
1998         Nothing -> return Nothing
1999         Just (new_ic, names, hval) -> do
2000                         -- Run it!
2001                 hvals <- (unsafeCoerce# hval) :: IO [HValue]
2002
2003                 case (names,hvals) of
2004                   ([n],[hv]) -> return (Just hv)
2005                   _          -> panic "compileExpr"
2006
2007 -- -----------------------------------------------------------------------------
2008 -- Compile an expression into a dynamic
2009
2010 dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
2011 dynCompileExpr ses expr = do
2012     (full,exports) <- getContext ses
2013     setContext ses full $
2014         (mkModule
2015             (stringToPackageId "base") (mkModuleName "Data.Dynamic")
2016         ):exports
2017     let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
2018     res <- withSession ses (flip hscStmt stmt)
2019     setContext ses full exports
2020     case res of
2021         Nothing -> return Nothing
2022         Just (_, names, hvals) -> do
2023             vals <- (unsafeCoerce# hvals :: IO [Dynamic])
2024             case (names,vals) of
2025                 (_:[], v:[])    -> return (Just v)
2026                 _               -> panic "dynCompileExpr"
2027
2028 -- -----------------------------------------------------------------------------
2029 -- running a statement interactively
2030
2031 data RunResult
2032   = RunOk [Name]                -- ^ names bound by this evaluation
2033   | RunFailed                   -- ^ statement failed compilation
2034   | RunException Exception      -- ^ statement raised an exception
2035
2036 -- | Run a statement in the current interactive context.  Statemenet
2037 -- may bind multple values.
2038 runStmt :: Session -> String -> IO RunResult
2039 runStmt (Session ref) expr
2040    = do
2041         hsc_env <- readIORef ref
2042
2043         -- Turn off -fwarn-unused-bindings when running a statement, to hide
2044         -- warnings about the implicit bindings we introduce.
2045         let dflags'  = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
2046             hsc_env' = hsc_env{ hsc_dflags = dflags' }
2047
2048         maybe_stuff <- hscStmt hsc_env' expr
2049
2050         case maybe_stuff of
2051            Nothing -> return RunFailed
2052            Just (new_hsc_env, names, hval) -> do
2053
2054                 let thing_to_run = unsafeCoerce# hval :: IO [HValue]
2055                 either_hvals <- sandboxIO thing_to_run
2056
2057                 case either_hvals of
2058                     Left e -> do
2059                         -- on error, keep the *old* interactive context,
2060                         -- so that 'it' is not bound to something
2061                         -- that doesn't exist.
2062                         return (RunException e)
2063
2064                     Right hvals -> do
2065                         -- Get the newly bound things, and bind them.
2066                         -- Don't need to delete any shadowed bindings;
2067                         -- the new ones override the old ones.
2068                         extendLinkEnv (zip names hvals)
2069
2070                         writeIORef ref new_hsc_env
2071                         return (RunOk names)
2072
2073 -- When running a computation, we redirect ^C exceptions to the running
2074 -- thread.  ToDo: we might want a way to continue even if the target
2075 -- thread doesn't die when it receives the exception... "this thread
2076 -- is not responding".
2077 sandboxIO :: IO a -> IO (Either Exception a)
2078 sandboxIO thing = do
2079   m <- newEmptyMVar
2080   ts <- takeMVar interruptTargetThread
2081   child <- forkIO (do res <- Exception.try thing; putMVar m res)
2082   putMVar interruptTargetThread (child:ts)
2083   takeMVar m `finally` modifyMVar_ interruptTargetThread (return.tail)
2084
2085 {-
2086 -- This version of sandboxIO runs the expression in a completely new
2087 -- RTS main thread.  It is disabled for now because ^C exceptions
2088 -- won't be delivered to the new thread, instead they'll be delivered
2089 -- to the (blocked) GHCi main thread.
2090
2091 -- SLPJ: when re-enabling this, reflect a wrong-stat error as an exception
2092
2093 sandboxIO :: IO a -> IO (Either Int (Either Exception a))
2094 sandboxIO thing = do
2095   st_thing <- newStablePtr (Exception.try thing)
2096   alloca $ \ p_st_result -> do
2097     stat <- rts_evalStableIO st_thing p_st_result
2098     freeStablePtr st_thing
2099     if stat == 1
2100         then do st_result <- peek p_st_result
2101                 result <- deRefStablePtr st_result
2102                 freeStablePtr st_result
2103                 return (Right result)
2104         else do
2105                 return (Left (fromIntegral stat))
2106
2107 foreign import "rts_evalStableIO"  {- safe -}
2108   rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt
2109   -- more informative than the C type!
2110 -}
2111
2112 -----------------------------------------------------------------------------
2113 -- show a module and it's source/object filenames
2114
2115 showModule :: Session -> ModSummary -> IO String
2116 showModule s mod_summary = withSession s $ \hsc_env -> do
2117   case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
2118         Nothing       -> panic "missing linkable"
2119         Just mod_info -> return (showModMsg (hscTarget (hsc_dflags hsc_env)) (not obj_linkable) mod_summary)
2120                       where
2121                          obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
2122
2123 #endif /* GHCI */