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