compiler/main/GHC.hs

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