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