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