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