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