| 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(..), HscEnv, |
|---|
| 16 | runGhc, runGhcT, initGhcMonad, |
|---|
| 17 | gcatch, gbracket, gfinally, |
|---|
| 18 | printException, |
|---|
| 19 | printExceptionAndWarnings, |
|---|
| 20 | handleSourceError, |
|---|
| 21 | needsTemplateHaskell, |
|---|
| 22 | |
|---|
| 23 | -- * Flags and settings |
|---|
| 24 | DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt, |
|---|
| 25 | GhcMode(..), GhcLink(..), defaultObjectTarget, |
|---|
| 26 | parseDynamicFlags, |
|---|
| 27 | getSessionDynFlags, setSessionDynFlags, |
|---|
| 28 | getProgramDynFlags, setProgramDynFlags, |
|---|
| 29 | getInteractiveDynFlags, setInteractiveDynFlags, |
|---|
| 30 | parseStaticFlags, |
|---|
| 31 | |
|---|
| 32 | -- * Targets |
|---|
| 33 | Target(..), TargetId(..), Phase, |
|---|
| 34 | setTargets, |
|---|
| 35 | getTargets, |
|---|
| 36 | addTarget, |
|---|
| 37 | removeTarget, |
|---|
| 38 | guessTarget, |
|---|
| 39 | |
|---|
| 40 | -- * Loading\/compiling the program |
|---|
| 41 | depanal, |
|---|
| 42 | load, LoadHowMuch(..), InteractiveImport(..), |
|---|
| 43 | SuccessFlag(..), succeeded, failed, |
|---|
| 44 | defaultWarnErrLogger, WarnErrLogger, |
|---|
| 45 | workingDirectoryChanged, |
|---|
| 46 | parseModule, typecheckModule, desugarModule, loadModule, |
|---|
| 47 | ParsedModule(..), TypecheckedModule(..), DesugaredModule(..), |
|---|
| 48 | TypecheckedSource, ParsedSource, RenamedSource, -- ditto |
|---|
| 49 | TypecheckedMod, ParsedMod, |
|---|
| 50 | moduleInfo, renamedSource, typecheckedSource, |
|---|
| 51 | parsedSource, coreModule, |
|---|
| 52 | |
|---|
| 53 | -- ** Compiling to Core |
|---|
| 54 | CoreModule(..), |
|---|
| 55 | compileToCoreModule, compileToCoreSimplified, |
|---|
| 56 | compileCoreToObj, |
|---|
| 57 | |
|---|
| 58 | -- * Inspecting the module structure of the program |
|---|
| 59 | ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..), |
|---|
| 60 | getModSummary, |
|---|
| 61 | getModuleGraph, |
|---|
| 62 | isLoaded, |
|---|
| 63 | topSortModuleGraph, |
|---|
| 64 | |
|---|
| 65 | -- * Inspecting modules |
|---|
| 66 | ModuleInfo, |
|---|
| 67 | getModuleInfo, |
|---|
| 68 | modInfoTyThings, |
|---|
| 69 | modInfoTopLevelScope, |
|---|
| 70 | modInfoExports, |
|---|
| 71 | modInfoInstances, |
|---|
| 72 | modInfoIsExportedName, |
|---|
| 73 | modInfoLookupName, |
|---|
| 74 | modInfoIface, |
|---|
| 75 | modInfoSafe, |
|---|
| 76 | lookupGlobalName, |
|---|
| 77 | findGlobalAnns, |
|---|
| 78 | mkPrintUnqualifiedForModule, |
|---|
| 79 | ModIface(..), |
|---|
| 80 | SafeHaskellMode(..), |
|---|
| 81 | |
|---|
| 82 | -- * Querying the environment |
|---|
| 83 | packageDbModules, |
|---|
| 84 | |
|---|
| 85 | -- * Printing |
|---|
| 86 | PrintUnqualified, alwaysQualify, |
|---|
| 87 | |
|---|
| 88 | -- * Interactive evaluation |
|---|
| 89 | getBindings, getInsts, getPrintUnqual, |
|---|
| 90 | findModule, lookupModule, |
|---|
| 91 | #ifdef GHCI |
|---|
| 92 | isModuleTrusted, |
|---|
| 93 | setContext, getContext, |
|---|
| 94 | getNamesInScope, |
|---|
| 95 | getRdrNamesInScope, |
|---|
| 96 | getGRE, |
|---|
| 97 | moduleIsInterpreted, |
|---|
| 98 | getInfo, |
|---|
| 99 | exprType, |
|---|
| 100 | typeKind, |
|---|
| 101 | parseName, |
|---|
| 102 | RunResult(..), |
|---|
| 103 | runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation, |
|---|
| 104 | parseImportDecl, SingleStep(..), |
|---|
| 105 | resume, |
|---|
| 106 | Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan, |
|---|
| 107 | resumeHistory, resumeHistoryIx), |
|---|
| 108 | History(historyBreakInfo, historyEnclosingDecls), |
|---|
| 109 | GHC.getHistorySpan, getHistoryModule, |
|---|
| 110 | getResumeContext, |
|---|
| 111 | abandon, abandonAll, |
|---|
| 112 | InteractiveEval.back, |
|---|
| 113 | InteractiveEval.forward, |
|---|
| 114 | showModule, |
|---|
| 115 | isModuleInterpreted, |
|---|
| 116 | InteractiveEval.compileExpr, HValue, dynCompileExpr, |
|---|
| 117 | GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType, |
|---|
| 118 | modInfoModBreaks, |
|---|
| 119 | ModBreaks(..), BreakIndex, |
|---|
| 120 | BreakInfo(breakInfo_number, breakInfo_module), |
|---|
| 121 | BreakArray, setBreakOn, setBreakOff, getBreak, |
|---|
| 122 | #endif |
|---|
| 123 | lookupName, |
|---|
| 124 | |
|---|
| 125 | #ifdef GHCI |
|---|
| 126 | -- ** EXPERIMENTAL |
|---|
| 127 | setGHCiMonad, |
|---|
| 128 | #endif |
|---|
| 129 | |
|---|
| 130 | -- * Abstract syntax elements |
|---|
| 131 | |
|---|
| 132 | -- ** Packages |
|---|
| 133 | PackageId, |
|---|
| 134 | |
|---|
| 135 | -- ** Modules |
|---|
| 136 | Module, mkModule, pprModule, moduleName, modulePackageId, |
|---|
| 137 | ModuleName, mkModuleName, moduleNameString, |
|---|
| 138 | |
|---|
| 139 | -- ** Names |
|---|
| 140 | Name, |
|---|
| 141 | isExternalName, nameModule, pprParenSymName, nameSrcSpan, |
|---|
| 142 | NamedThing(..), |
|---|
| 143 | RdrName(Qual,Unqual), |
|---|
| 144 | |
|---|
| 145 | -- ** Identifiers |
|---|
| 146 | Id, idType, |
|---|
| 147 | isImplicitId, isDeadBinder, |
|---|
| 148 | isExportedId, isLocalId, isGlobalId, |
|---|
| 149 | isRecordSelector, |
|---|
| 150 | isPrimOpId, isFCallId, isClassOpId_maybe, |
|---|
| 151 | isDataConWorkId, idDataCon, |
|---|
| 152 | isBottomingId, isDictonaryId, |
|---|
| 153 | recordSelectorFieldLabel, |
|---|
| 154 | |
|---|
| 155 | -- ** Type constructors |
|---|
| 156 | TyCon, |
|---|
| 157 | tyConTyVars, tyConDataCons, tyConArity, |
|---|
| 158 | isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, |
|---|
| 159 | isFamilyTyCon, tyConClass_maybe, |
|---|
| 160 | synTyConDefn, synTyConType, synTyConResKind, |
|---|
| 161 | |
|---|
| 162 | -- ** Type variables |
|---|
| 163 | TyVar, |
|---|
| 164 | alphaTyVars, |
|---|
| 165 | |
|---|
| 166 | -- ** Data constructors |
|---|
| 167 | DataCon, |
|---|
| 168 | dataConSig, dataConType, dataConTyCon, dataConFieldLabels, |
|---|
| 169 | dataConIsInfix, isVanillaDataCon, dataConUserType, |
|---|
| 170 | dataConStrictMarks, |
|---|
| 171 | StrictnessMark(..), isMarkedStrict, |
|---|
| 172 | |
|---|
| 173 | -- ** Classes |
|---|
| 174 | Class, |
|---|
| 175 | classMethods, classSCTheta, classTvsFds, classATs, |
|---|
| 176 | pprFundeps, |
|---|
| 177 | |
|---|
| 178 | -- ** Instances |
|---|
| 179 | ClsInst, |
|---|
| 180 | instanceDFunId, |
|---|
| 181 | pprInstance, pprInstanceHdr, |
|---|
| 182 | pprFamInst, pprFamInstHdr, |
|---|
| 183 | |
|---|
| 184 | -- ** Types and Kinds |
|---|
| 185 | Type, splitForAllTys, funResultTy, |
|---|
| 186 | pprParendType, pprTypeApp, |
|---|
| 187 | Kind, |
|---|
| 188 | PredType, |
|---|
| 189 | ThetaType, pprForAll, pprThetaArrowTy, |
|---|
| 190 | |
|---|
| 191 | -- ** Entities |
|---|
| 192 | TyThing(..), |
|---|
| 193 | |
|---|
| 194 | -- ** Syntax |
|---|
| 195 | module HsSyn, -- ToDo: remove extraneous bits |
|---|
| 196 | |
|---|
| 197 | -- ** Fixities |
|---|
| 198 | FixityDirection(..), |
|---|
| 199 | defaultFixity, maxPrecedence, |
|---|
| 200 | negateFixity, |
|---|
| 201 | compareFixity, |
|---|
| 202 | |
|---|
| 203 | -- ** Source locations |
|---|
| 204 | SrcLoc(..), RealSrcLoc, |
|---|
| 205 | mkSrcLoc, noSrcLoc, |
|---|
| 206 | srcLocFile, srcLocLine, srcLocCol, |
|---|
| 207 | SrcSpan(..), RealSrcSpan, |
|---|
| 208 | mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan, |
|---|
| 209 | srcSpanStart, srcSpanEnd, |
|---|
| 210 | srcSpanFile, |
|---|
| 211 | srcSpanStartLine, srcSpanEndLine, |
|---|
| 212 | srcSpanStartCol, srcSpanEndCol, |
|---|
| 213 | |
|---|
| 214 | -- ** Located |
|---|
| 215 | GenLocated(..), Located, |
|---|
| 216 | |
|---|
| 217 | -- *** Constructing Located |
|---|
| 218 | noLoc, mkGeneralLocated, |
|---|
| 219 | |
|---|
| 220 | -- *** Deconstructing Located |
|---|
| 221 | getLoc, unLoc, |
|---|
| 222 | |
|---|
| 223 | -- *** Combining and comparing Located values |
|---|
| 224 | eqLocated, cmpLocated, combineLocs, addCLoc, |
|---|
| 225 | leftmost_smallest, leftmost_largest, rightmost, |
|---|
| 226 | spans, isSubspanOf, |
|---|
| 227 | |
|---|
| 228 | -- * Exceptions |
|---|
| 229 | GhcException(..), showGhcException, |
|---|
| 230 | |
|---|
| 231 | -- * Token stream manipulations |
|---|
| 232 | Token, |
|---|
| 233 | getTokenStream, getRichTokenStream, |
|---|
| 234 | showRichTokenStream, addSourceToTokens, |
|---|
| 235 | |
|---|
| 236 | -- * Pure interface to the parser |
|---|
| 237 | parser, |
|---|
| 238 | |
|---|
| 239 | -- * Miscellaneous |
|---|
| 240 | --sessionHscEnv, |
|---|
| 241 | cyclicModuleErr, |
|---|
| 242 | ) where |
|---|
| 243 | |
|---|
| 244 | {- |
|---|
| 245 | ToDo: |
|---|
| 246 | |
|---|
| 247 | * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt. |
|---|
| 248 | * what StaticFlags should we expose, if any? |
|---|
| 249 | -} |
|---|
| 250 | |
|---|
| 251 | #include "HsVersions.h" |
|---|
| 252 | |
|---|
| 253 | #ifdef GHCI |
|---|
| 254 | import Linker ( HValue ) |
|---|
| 255 | import ByteCodeInstr |
|---|
| 256 | import BreakArray |
|---|
| 257 | import InteractiveEval |
|---|
| 258 | #endif |
|---|
| 259 | |
|---|
| 260 | import HscMain |
|---|
| 261 | import GhcMake |
|---|
| 262 | import DriverPipeline ( compile' ) |
|---|
| 263 | import GhcMonad |
|---|
| 264 | import TcRnMonad ( finalSafeMode ) |
|---|
| 265 | import TcRnTypes |
|---|
| 266 | import Packages |
|---|
| 267 | import NameSet |
|---|
| 268 | import RdrName |
|---|
| 269 | import qualified HsSyn -- hack as we want to reexport the whole module |
|---|
| 270 | import HsSyn |
|---|
| 271 | import Type hiding( typeKind ) |
|---|
| 272 | import Kind ( synTyConResKind ) |
|---|
| 273 | import TcType hiding( typeKind ) |
|---|
| 274 | import Id |
|---|
| 275 | import TysPrim ( alphaTyVars ) |
|---|
| 276 | import TyCon |
|---|
| 277 | import Class |
|---|
| 278 | import DataCon |
|---|
| 279 | import Name hiding ( varName ) |
|---|
| 280 | import Avail |
|---|
| 281 | import InstEnv |
|---|
| 282 | import FamInstEnv |
|---|
| 283 | import SrcLoc |
|---|
| 284 | import CoreSyn |
|---|
| 285 | import TidyPgm |
|---|
| 286 | import DriverPhases ( Phase(..), isHaskellSrcFilename ) |
|---|
| 287 | import Finder |
|---|
| 288 | import HscTypes |
|---|
| 289 | import DynFlags |
|---|
| 290 | import StaticFlagParser |
|---|
| 291 | import qualified StaticFlags |
|---|
| 292 | import SysTools |
|---|
| 293 | import Annotations |
|---|
| 294 | import Module |
|---|
| 295 | import UniqFM |
|---|
| 296 | import Panic |
|---|
| 297 | import Bag ( unitBag ) |
|---|
| 298 | import ErrUtils |
|---|
| 299 | import MonadUtils |
|---|
| 300 | import Util |
|---|
| 301 | import StringBuffer |
|---|
| 302 | import Outputable |
|---|
| 303 | import BasicTypes |
|---|
| 304 | import Maybes ( expectJust ) |
|---|
| 305 | import FastString |
|---|
| 306 | import qualified Parser |
|---|
| 307 | import Lexer |
|---|
| 308 | |
|---|
| 309 | import System.Directory ( doesFileExist, getCurrentDirectory ) |
|---|
| 310 | import Data.Maybe |
|---|
| 311 | import Data.List ( find ) |
|---|
| 312 | import Data.Time |
|---|
| 313 | import Data.Typeable ( Typeable ) |
|---|
| 314 | import Data.Word ( Word8 ) |
|---|
| 315 | import Control.Monad |
|---|
| 316 | import System.Exit ( exitWith, ExitCode(..) ) |
|---|
| 317 | import Exception |
|---|
| 318 | import Data.IORef |
|---|
| 319 | import System.FilePath |
|---|
| 320 | import System.IO |
|---|
| 321 | import Prelude hiding (init) |
|---|
| 322 | |
|---|
| 323 | |
|---|
| 324 | -- %************************************************************************ |
|---|
| 325 | -- %* * |
|---|
| 326 | -- Initialisation: exception handlers |
|---|
| 327 | -- %* * |
|---|
| 328 | -- %************************************************************************ |
|---|
| 329 | |
|---|
| 330 | |
|---|
| 331 | -- | Install some default exception handlers and run the inner computation. |
|---|
| 332 | -- Unless you want to handle exceptions yourself, you should wrap this around |
|---|
| 333 | -- the top level of your program. The default handlers output the error |
|---|
| 334 | -- message(s) to stderr and exit cleanly. |
|---|
| 335 | defaultErrorHandler :: (ExceptionMonad m, MonadIO m) |
|---|
| 336 | => LogAction -> FlushOut -> m a -> m a |
|---|
| 337 | defaultErrorHandler la (FlushOut flushOut) inner = |
|---|
| 338 | -- top-level exception handler: any unrecognised exception is a compiler bug. |
|---|
| 339 | ghandle (\exception -> liftIO $ do |
|---|
| 340 | flushOut |
|---|
| 341 | case fromException exception of |
|---|
| 342 | -- an IO exception probably isn't our fault, so don't panic |
|---|
| 343 | Just (ioe :: IOException) -> |
|---|
| 344 | fatalErrorMsg' la (text (show ioe)) |
|---|
| 345 | _ -> case fromException exception of |
|---|
| 346 | Just UserInterrupt -> exitWith (ExitFailure 1) |
|---|
| 347 | Just StackOverflow -> |
|---|
| 348 | fatalErrorMsg' la (text "stack overflow: use +RTS -K<size> to increase it") |
|---|
| 349 | _ -> case fromException exception of |
|---|
| 350 | Just (ex :: ExitCode) -> throw ex |
|---|
| 351 | _ -> |
|---|
| 352 | fatalErrorMsg' la |
|---|
| 353 | (text (show (Panic (show exception)))) |
|---|
| 354 | exitWith (ExitFailure 1) |
|---|
| 355 | ) $ |
|---|
| 356 | |
|---|
| 357 | -- error messages propagated as exceptions |
|---|
| 358 | handleGhcException |
|---|
| 359 | (\ge -> liftIO $ do |
|---|
| 360 | flushOut |
|---|
| 361 | case ge of |
|---|
| 362 | PhaseFailed _ code -> exitWith code |
|---|
| 363 | Signal _ -> exitWith (ExitFailure 1) |
|---|
| 364 | _ -> do fatalErrorMsg' la (text (show ge)) |
|---|
| 365 | exitWith (ExitFailure 1) |
|---|
| 366 | ) $ |
|---|
| 367 | inner |
|---|
| 368 | |
|---|
| 369 | -- | Install a default cleanup handler to remove temporary files deposited by |
|---|
| 370 | -- a GHC run. This is seperate from 'defaultErrorHandler', because you might |
|---|
| 371 | -- want to override the error handling, but still get the ordinary cleanup |
|---|
| 372 | -- behaviour. |
|---|
| 373 | defaultCleanupHandler :: (ExceptionMonad m, MonadIO m) => |
|---|
| 374 | DynFlags -> m a -> m a |
|---|
| 375 | defaultCleanupHandler dflags inner = |
|---|
| 376 | -- make sure we clean up after ourselves |
|---|
| 377 | inner `gfinally` |
|---|
| 378 | (liftIO $ do |
|---|
| 379 | cleanTempFiles dflags |
|---|
| 380 | cleanTempDirs dflags |
|---|
| 381 | ) |
|---|
| 382 | -- exceptions will be blocked while we clean the temporary files, |
|---|
| 383 | -- so there shouldn't be any difficulty if we receive further |
|---|
| 384 | -- signals. |
|---|
| 385 | |
|---|
| 386 | |
|---|
| 387 | -- %************************************************************************ |
|---|
| 388 | -- %* * |
|---|
| 389 | -- The Ghc Monad |
|---|
| 390 | -- %* * |
|---|
| 391 | -- %************************************************************************ |
|---|
| 392 | |
|---|
| 393 | -- | Run function for the 'Ghc' monad. |
|---|
| 394 | -- |
|---|
| 395 | -- It initialises the GHC session and warnings via 'initGhcMonad'. Each call |
|---|
| 396 | -- to this function will create a new session which should not be shared among |
|---|
| 397 | -- several threads. |
|---|
| 398 | -- |
|---|
| 399 | -- Any errors not handled inside the 'Ghc' action are propagated as IO |
|---|
| 400 | -- exceptions. |
|---|
| 401 | |
|---|
| 402 | runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'. |
|---|
| 403 | -> Ghc a -- ^ The action to perform. |
|---|
| 404 | -> IO a |
|---|
| 405 | runGhc mb_top_dir ghc = do |
|---|
| 406 | ref <- newIORef (panic "empty session") |
|---|
| 407 | let session = Session ref |
|---|
| 408 | flip unGhc session $ do |
|---|
| 409 | initGhcMonad mb_top_dir |
|---|
| 410 | ghc |
|---|
| 411 | -- XXX: unregister interrupt handlers here? |
|---|
| 412 | |
|---|
| 413 | -- | Run function for 'GhcT' monad transformer. |
|---|
| 414 | -- |
|---|
| 415 | -- It initialises the GHC session and warnings via 'initGhcMonad'. Each call |
|---|
| 416 | -- to this function will create a new session which should not be shared among |
|---|
| 417 | -- several threads. |
|---|
| 418 | |
|---|
| 419 | runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) => |
|---|
| 420 | Maybe FilePath -- ^ See argument to 'initGhcMonad'. |
|---|
| 421 | -> GhcT m a -- ^ The action to perform. |
|---|
| 422 | -> m a |
|---|
| 423 | runGhcT mb_top_dir ghct = do |
|---|
| 424 | ref <- liftIO $ newIORef (panic "empty session") |
|---|
| 425 | let session = Session ref |
|---|
| 426 | flip unGhcT session $ do |
|---|
| 427 | initGhcMonad mb_top_dir |
|---|
| 428 | ghct |
|---|
| 429 | |
|---|
| 430 | -- | Initialise a GHC session. |
|---|
| 431 | -- |
|---|
| 432 | -- If you implement a custom 'GhcMonad' you must call this function in the |
|---|
| 433 | -- monad run function. It will initialise the session variable and clear all |
|---|
| 434 | -- warnings. |
|---|
| 435 | -- |
|---|
| 436 | -- The first argument should point to the directory where GHC's library files |
|---|
| 437 | -- reside. More precisely, this should be the output of @ghc --print-libdir@ |
|---|
| 438 | -- of the version of GHC the module using this API is compiled with. For |
|---|
| 439 | -- portability, you should use the @ghc-paths@ package, available at |
|---|
| 440 | -- <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/ghc-paths>. |
|---|
| 441 | |
|---|
| 442 | initGhcMonad :: GhcMonad m => Maybe FilePath -> m () |
|---|
| 443 | initGhcMonad mb_top_dir = do |
|---|
| 444 | -- catch ^C |
|---|
| 445 | liftIO $ installSignalHandlers |
|---|
| 446 | |
|---|
| 447 | liftIO $ StaticFlags.initStaticOpts |
|---|
| 448 | |
|---|
| 449 | mySettings <- liftIO $ initSysTools mb_top_dir |
|---|
| 450 | dflags <- liftIO $ initDynFlags (defaultDynFlags mySettings) |
|---|
| 451 | env <- liftIO $ newHscEnv dflags |
|---|
| 452 | setSession env |
|---|
| 453 | |
|---|
| 454 | |
|---|
| 455 | -- %************************************************************************ |
|---|
| 456 | -- %* * |
|---|
| 457 | -- Flags & settings |
|---|
| 458 | -- %* * |
|---|
| 459 | -- %************************************************************************ |
|---|
| 460 | |
|---|
| 461 | -- $DynFlags |
|---|
| 462 | -- |
|---|
| 463 | -- The GHC session maintains two sets of 'DynFlags': |
|---|
| 464 | -- |
|---|
| 465 | -- * The "interactive" @DynFlags@, which are used for everything |
|---|
| 466 | -- related to interactive evaluation, including 'runStmt', |
|---|
| 467 | -- 'runDecls', 'exprType', 'lookupName' and so on (everything |
|---|
| 468 | -- under \"Interactive evaluation\" in this module). |
|---|
| 469 | -- |
|---|
| 470 | -- * The "program" @DynFlags@, which are used when loading |
|---|
| 471 | -- whole modules with 'load' |
|---|
| 472 | -- |
|---|
| 473 | -- 'setInteractiveDynFlags', 'getInteractiveDynFlags' work with the |
|---|
| 474 | -- interactive @DynFlags@. |
|---|
| 475 | -- |
|---|
| 476 | -- 'setProgramDynFlags', 'getProgramDynFlags' work with the |
|---|
| 477 | -- program @DynFlags@. |
|---|
| 478 | -- |
|---|
| 479 | -- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags' |
|---|
| 480 | -- retrieves the program @DynFlags@ (for backwards compatibility). |
|---|
| 481 | |
|---|
| 482 | |
|---|
| 483 | -- | Updates both the interactive and program DynFlags in a Session. |
|---|
| 484 | -- This also reads the package database (unless it has already been |
|---|
| 485 | -- read), and prepares the compilers knowledge about packages. It can |
|---|
| 486 | -- be called again to load new packages: just add new package flags to |
|---|
| 487 | -- (packageFlags dflags). |
|---|
| 488 | -- |
|---|
| 489 | -- Returns a list of new packages that may need to be linked in using |
|---|
| 490 | -- the dynamic linker (see 'linkPackages') as a result of new package |
|---|
| 491 | -- flags. If you are not doing linking or doing static linking, you |
|---|
| 492 | -- can ignore the list of packages returned. |
|---|
| 493 | -- |
|---|
| 494 | setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId] |
|---|
| 495 | setSessionDynFlags dflags = do |
|---|
| 496 | (dflags', preload) <- liftIO $ initPackages dflags |
|---|
| 497 | modifySession $ \h -> h{ hsc_dflags = dflags' |
|---|
| 498 | , hsc_IC = (hsc_IC h){ ic_dflags = dflags' } } |
|---|
| 499 | return preload |
|---|
| 500 | |
|---|
| 501 | -- | Sets the program 'DynFlags'. |
|---|
| 502 | setProgramDynFlags :: GhcMonad m => DynFlags -> m [PackageId] |
|---|
| 503 | setProgramDynFlags dflags = do |
|---|
| 504 | (dflags', preload) <- liftIO $ initPackages dflags |
|---|
| 505 | modifySession $ \h -> h{ hsc_dflags = dflags' } |
|---|
| 506 | return preload |
|---|
| 507 | |
|---|
| 508 | -- | Returns the program 'DynFlags'. |
|---|
| 509 | getProgramDynFlags :: GhcMonad m => m DynFlags |
|---|
| 510 | getProgramDynFlags = getSessionDynFlags |
|---|
| 511 | |
|---|
| 512 | -- | Set the 'DynFlags' used to evaluate interactive expressions. |
|---|
| 513 | -- Note: this cannot be used for changes to packages. Use |
|---|
| 514 | -- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the |
|---|
| 515 | -- 'pkgState' into the interactive @DynFlags@. |
|---|
| 516 | setInteractiveDynFlags :: GhcMonad m => DynFlags -> m () |
|---|
| 517 | setInteractiveDynFlags dflags = do |
|---|
| 518 | modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags }} |
|---|
| 519 | |
|---|
| 520 | -- | Get the 'DynFlags' used to evaluate interactive expressions. |
|---|
| 521 | getInteractiveDynFlags :: GhcMonad m => m DynFlags |
|---|
| 522 | getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h)) |
|---|
| 523 | |
|---|
| 524 | |
|---|
| 525 | parseDynamicFlags :: Monad m => |
|---|
| 526 | DynFlags -> [Located String] |
|---|
| 527 | -> m (DynFlags, [Located String], [Located String]) |
|---|
| 528 | parseDynamicFlags = parseDynamicFlagsCmdLine |
|---|
| 529 | |
|---|
| 530 | |
|---|
| 531 | -- %************************************************************************ |
|---|
| 532 | -- %* * |
|---|
| 533 | -- Setting, getting, and modifying the targets |
|---|
| 534 | -- %* * |
|---|
| 535 | -- %************************************************************************ |
|---|
| 536 | |
|---|
| 537 | -- ToDo: think about relative vs. absolute file paths. And what |
|---|
| 538 | -- happens when the current directory changes. |
|---|
| 539 | |
|---|
| 540 | -- | Sets the targets for this session. Each target may be a module name |
|---|
| 541 | -- or a filename. The targets correspond to the set of root modules for |
|---|
| 542 | -- the program\/library. Unloading the current program is achieved by |
|---|
| 543 | -- setting the current set of targets to be empty, followed by 'load'. |
|---|
| 544 | setTargets :: GhcMonad m => [Target] -> m () |
|---|
| 545 | setTargets targets = modifySession (\h -> h{ hsc_targets = targets }) |
|---|
| 546 | |
|---|
| 547 | -- | Returns the current set of targets |
|---|
| 548 | getTargets :: GhcMonad m => m [Target] |
|---|
| 549 | getTargets = withSession (return . hsc_targets) |
|---|
| 550 | |
|---|
| 551 | -- | Add another target. |
|---|
| 552 | addTarget :: GhcMonad m => Target -> m () |
|---|
| 553 | addTarget target |
|---|
| 554 | = modifySession (\h -> h{ hsc_targets = target : hsc_targets h }) |
|---|
| 555 | |
|---|
| 556 | -- | Remove a target |
|---|
| 557 | removeTarget :: GhcMonad m => TargetId -> m () |
|---|
| 558 | removeTarget target_id |
|---|
| 559 | = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) }) |
|---|
| 560 | where |
|---|
| 561 | filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ] |
|---|
| 562 | |
|---|
| 563 | -- | Attempts to guess what Target a string refers to. This function |
|---|
| 564 | -- implements the @--make@/GHCi command-line syntax for filenames: |
|---|
| 565 | -- |
|---|
| 566 | -- - if the string looks like a Haskell source filename, then interpret it |
|---|
| 567 | -- as such |
|---|
| 568 | -- |
|---|
| 569 | -- - if adding a .hs or .lhs suffix yields the name of an existing file, |
|---|
| 570 | -- then use that |
|---|
| 571 | -- |
|---|
| 572 | -- - otherwise interpret the string as a module name |
|---|
| 573 | -- |
|---|
| 574 | guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target |
|---|
| 575 | guessTarget str (Just phase) |
|---|
| 576 | = return (Target (TargetFile str (Just phase)) True Nothing) |
|---|
| 577 | guessTarget str Nothing |
|---|
| 578 | | isHaskellSrcFilename file |
|---|
| 579 | = return (target (TargetFile file Nothing)) |
|---|
| 580 | | otherwise |
|---|
| 581 | = do exists <- liftIO $ doesFileExist hs_file |
|---|
| 582 | if exists |
|---|
| 583 | then return (target (TargetFile hs_file Nothing)) |
|---|
| 584 | else do |
|---|
| 585 | exists <- liftIO $ doesFileExist lhs_file |
|---|
| 586 | if exists |
|---|
| 587 | then return (target (TargetFile lhs_file Nothing)) |
|---|
| 588 | else do |
|---|
| 589 | if looksLikeModuleName file |
|---|
| 590 | then return (target (TargetModule (mkModuleName file))) |
|---|
| 591 | else do |
|---|
| 592 | throwGhcException |
|---|
| 593 | (ProgramError (showSDoc $ |
|---|
| 594 | text "target" <+> quotes (text file) <+> |
|---|
| 595 | text "is not a module name or a source file")) |
|---|
| 596 | where |
|---|
| 597 | (file,obj_allowed) |
|---|
| 598 | | '*':rest <- str = (rest, False) |
|---|
| 599 | | otherwise = (str, True) |
|---|
| 600 | |
|---|
| 601 | hs_file = file <.> "hs" |
|---|
| 602 | lhs_file = file <.> "lhs" |
|---|
| 603 | |
|---|
| 604 | target tid = Target tid obj_allowed Nothing |
|---|
| 605 | |
|---|
| 606 | |
|---|
| 607 | -- | Inform GHC that the working directory has changed. GHC will flush |
|---|
| 608 | -- its cache of module locations, since it may no longer be valid. |
|---|
| 609 | -- |
|---|
| 610 | -- Note: Before changing the working directory make sure all threads running |
|---|
| 611 | -- in the same session have stopped. If you change the working directory, |
|---|
| 612 | -- you should also unload the current program (set targets to empty, |
|---|
| 613 | -- followed by load). |
|---|
| 614 | workingDirectoryChanged :: GhcMonad m => m () |
|---|
| 615 | workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches) |
|---|
| 616 | |
|---|
| 617 | |
|---|
| 618 | -- %************************************************************************ |
|---|
| 619 | -- %* * |
|---|
| 620 | -- Running phases one at a time |
|---|
| 621 | -- %* * |
|---|
| 622 | -- %************************************************************************ |
|---|
| 623 | |
|---|
| 624 | class ParsedMod m where |
|---|
| 625 | modSummary :: m -> ModSummary |
|---|
| 626 | parsedSource :: m -> ParsedSource |
|---|
| 627 | |
|---|
| 628 | class ParsedMod m => TypecheckedMod m where |
|---|
| 629 | renamedSource :: m -> Maybe RenamedSource |
|---|
| 630 | typecheckedSource :: m -> TypecheckedSource |
|---|
| 631 | moduleInfo :: m -> ModuleInfo |
|---|
| 632 | tm_internals :: m -> (TcGblEnv, ModDetails) |
|---|
| 633 | -- ToDo: improvements that could be made here: |
|---|
| 634 | -- if the module succeeded renaming but not typechecking, |
|---|
| 635 | -- we can still get back the GlobalRdrEnv and exports, so |
|---|
| 636 | -- perhaps the ModuleInfo should be split up into separate |
|---|
| 637 | -- fields. |
|---|
| 638 | |
|---|
| 639 | class TypecheckedMod m => DesugaredMod m where |
|---|
| 640 | coreModule :: m -> ModGuts |
|---|
| 641 | |
|---|
| 642 | -- | The result of successful parsing. |
|---|
| 643 | data ParsedModule = |
|---|
| 644 | ParsedModule { pm_mod_summary :: ModSummary |
|---|
| 645 | , pm_parsed_source :: ParsedSource |
|---|
| 646 | , pm_extra_src_files :: [FilePath] } |
|---|
| 647 | |
|---|
| 648 | instance ParsedMod ParsedModule where |
|---|
| 649 | modSummary m = pm_mod_summary m |
|---|
| 650 | parsedSource m = pm_parsed_source m |
|---|
| 651 | |
|---|
| 652 | -- | The result of successful typechecking. It also contains the parser |
|---|
| 653 | -- result. |
|---|
| 654 | data TypecheckedModule = |
|---|
| 655 | TypecheckedModule { tm_parsed_module :: ParsedModule |
|---|
| 656 | , tm_renamed_source :: Maybe RenamedSource |
|---|
| 657 | , tm_typechecked_source :: TypecheckedSource |
|---|
| 658 | , tm_checked_module_info :: ModuleInfo |
|---|
| 659 | , tm_internals_ :: (TcGblEnv, ModDetails) |
|---|
| 660 | } |
|---|
| 661 | |
|---|
| 662 | instance ParsedMod TypecheckedModule where |
|---|
| 663 | modSummary m = modSummary (tm_parsed_module m) |
|---|
| 664 | parsedSource m = parsedSource (tm_parsed_module m) |
|---|
| 665 | |
|---|
| 666 | instance TypecheckedMod TypecheckedModule where |
|---|
| 667 | renamedSource m = tm_renamed_source m |
|---|
| 668 | typecheckedSource m = tm_typechecked_source m |
|---|
| 669 | moduleInfo m = tm_checked_module_info m |
|---|
| 670 | tm_internals m = tm_internals_ m |
|---|
| 671 | |
|---|
| 672 | -- | The result of successful desugaring (i.e., translation to core). Also |
|---|
| 673 | -- contains all the information of a typechecked module. |
|---|
| 674 | data DesugaredModule = |
|---|
| 675 | DesugaredModule { dm_typechecked_module :: TypecheckedModule |
|---|
| 676 | , dm_core_module :: ModGuts |
|---|
| 677 | } |
|---|
| 678 | |
|---|
| 679 | instance ParsedMod DesugaredModule where |
|---|
| 680 | modSummary m = modSummary (dm_typechecked_module m) |
|---|
| 681 | parsedSource m = parsedSource (dm_typechecked_module m) |
|---|
| 682 | |
|---|
| 683 | instance TypecheckedMod DesugaredModule where |
|---|
| 684 | renamedSource m = renamedSource (dm_typechecked_module m) |
|---|
| 685 | typecheckedSource m = typecheckedSource (dm_typechecked_module m) |
|---|
| 686 | moduleInfo m = moduleInfo (dm_typechecked_module m) |
|---|
| 687 | tm_internals m = tm_internals_ (dm_typechecked_module m) |
|---|
| 688 | |
|---|
| 689 | instance DesugaredMod DesugaredModule where |
|---|
| 690 | coreModule m = dm_core_module m |
|---|
| 691 | |
|---|
| 692 | type ParsedSource = Located (HsModule RdrName) |
|---|
| 693 | type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], |
|---|
| 694 | Maybe LHsDocString) |
|---|
| 695 | type TypecheckedSource = LHsBinds Id |
|---|
| 696 | |
|---|
| 697 | -- NOTE: |
|---|
| 698 | -- - things that aren't in the output of the typechecker right now: |
|---|
| 699 | -- - the export list |
|---|
| 700 | -- - the imports |
|---|
| 701 | -- - type signatures |
|---|
| 702 | -- - type/data/newtype declarations |
|---|
| 703 | -- - class declarations |
|---|
| 704 | -- - instances |
|---|
| 705 | -- - extra things in the typechecker's output: |
|---|
| 706 | -- - default methods are turned into top-level decls. |
|---|
| 707 | -- - dictionary bindings |
|---|
| 708 | |
|---|
| 709 | -- | Return the 'ModSummary' of a module with the given name. |
|---|
| 710 | -- |
|---|
| 711 | -- The module must be part of the module graph (see 'hsc_mod_graph' and |
|---|
| 712 | -- 'ModuleGraph'). If this is not the case, this function will throw a |
|---|
| 713 | -- 'GhcApiError'. |
|---|
| 714 | -- |
|---|
| 715 | -- This function ignores boot modules and requires that there is only one |
|---|
| 716 | -- non-boot module with the given name. |
|---|
| 717 | getModSummary :: GhcMonad m => ModuleName -> m ModSummary |
|---|
| 718 | getModSummary mod = do |
|---|
| 719 | mg <- liftM hsc_mod_graph getSession |
|---|
| 720 | case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of |
|---|
| 721 | [] -> throw $ mkApiErr (text "Module not part of module graph") |
|---|
| 722 | [ms] -> return ms |
|---|
| 723 | multiple -> throw $ mkApiErr (text "getModSummary is ambiguous: " <+> ppr multiple) |
|---|
| 724 | |
|---|
| 725 | -- | Parse a module. |
|---|
| 726 | -- |
|---|
| 727 | -- Throws a 'SourceError' on parse error. |
|---|
| 728 | parseModule :: GhcMonad m => ModSummary -> m ParsedModule |
|---|
| 729 | parseModule ms = do |
|---|
| 730 | hsc_env <- getSession |
|---|
| 731 | let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } |
|---|
| 732 | hpm <- liftIO $ hscParse hsc_env_tmp ms |
|---|
| 733 | return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)) |
|---|
| 734 | |
|---|
| 735 | -- | Typecheck and rename a parsed module. |
|---|
| 736 | -- |
|---|
| 737 | -- Throws a 'SourceError' if either fails. |
|---|
| 738 | typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule |
|---|
| 739 | typecheckModule pmod = do |
|---|
| 740 | let ms = modSummary pmod |
|---|
| 741 | hsc_env <- getSession |
|---|
| 742 | let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } |
|---|
| 743 | (tc_gbl_env, rn_info) |
|---|
| 744 | <- liftIO $ hscTypecheckRename hsc_env_tmp ms $ |
|---|
| 745 | HsParsedModule { hpm_module = parsedSource pmod, |
|---|
| 746 | hpm_src_files = pm_extra_src_files pmod } |
|---|
| 747 | details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env |
|---|
| 748 | safe <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env |
|---|
| 749 | return $ |
|---|
| 750 | TypecheckedModule { |
|---|
| 751 | tm_internals_ = (tc_gbl_env, details), |
|---|
| 752 | tm_parsed_module = pmod, |
|---|
| 753 | tm_renamed_source = rn_info, |
|---|
| 754 | tm_typechecked_source = tcg_binds tc_gbl_env, |
|---|
| 755 | tm_checked_module_info = |
|---|
| 756 | ModuleInfo { |
|---|
| 757 | minf_type_env = md_types details, |
|---|
| 758 | minf_exports = availsToNameSet $ md_exports details, |
|---|
| 759 | minf_rdr_env = Just (tcg_rdr_env tc_gbl_env), |
|---|
| 760 | minf_instances = md_insts details, |
|---|
| 761 | minf_iface = Nothing, |
|---|
| 762 | minf_safe = safe |
|---|
| 763 | #ifdef GHCI |
|---|
| 764 | ,minf_modBreaks = emptyModBreaks |
|---|
| 765 | #endif |
|---|
| 766 | }} |
|---|
| 767 | |
|---|
| 768 | -- | Desugar a typechecked module. |
|---|
| 769 | desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule |
|---|
| 770 | desugarModule tcm = do |
|---|
| 771 | let ms = modSummary tcm |
|---|
| 772 | let (tcg, _) = tm_internals tcm |
|---|
| 773 | hsc_env <- getSession |
|---|
| 774 | let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } |
|---|
| 775 | guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg |
|---|
| 776 | return $ |
|---|
| 777 | DesugaredModule { |
|---|
| 778 | dm_typechecked_module = tcm, |
|---|
| 779 | dm_core_module = guts |
|---|
| 780 | } |
|---|
| 781 | |
|---|
| 782 | -- | Load a module. Input doesn't need to be desugared. |
|---|
| 783 | -- |
|---|
| 784 | -- A module must be loaded before dependent modules can be typechecked. This |
|---|
| 785 | -- always includes generating a 'ModIface' and, depending on the |
|---|
| 786 | -- 'DynFlags.hscTarget', may also include code generation. |
|---|
| 787 | -- |
|---|
| 788 | -- This function will always cause recompilation and will always overwrite |
|---|
| 789 | -- previous compilation results (potentially files on disk). |
|---|
| 790 | -- |
|---|
| 791 | loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod |
|---|
| 792 | loadModule tcm = do |
|---|
| 793 | let ms = modSummary tcm |
|---|
| 794 | let mod = ms_mod_name ms |
|---|
| 795 | let loc = ms_location ms |
|---|
| 796 | let (tcg, _details) = tm_internals tcm |
|---|
| 797 | |
|---|
| 798 | mb_linkable <- case ms_obj_date ms of |
|---|
| 799 | Just t | t > ms_hs_date ms -> do |
|---|
| 800 | l <- liftIO $ findObjectLinkable (ms_mod ms) |
|---|
| 801 | (ml_obj_file loc) t |
|---|
| 802 | return (Just l) |
|---|
| 803 | _otherwise -> return Nothing |
|---|
| 804 | |
|---|
| 805 | let source_modified | isNothing mb_linkable = SourceModified |
|---|
| 806 | | otherwise = SourceUnmodified |
|---|
| 807 | -- we can't determine stability here |
|---|
| 808 | |
|---|
| 809 | -- compile doesn't change the session |
|---|
| 810 | hsc_env <- getSession |
|---|
| 811 | mod_info <- liftIO $ compile' (hscNothingBackendOnly tcg, |
|---|
| 812 | hscInteractiveBackendOnly tcg, |
|---|
| 813 | hscBatchBackendOnly tcg) |
|---|
| 814 | hsc_env ms 1 1 Nothing mb_linkable |
|---|
| 815 | source_modified |
|---|
| 816 | |
|---|
| 817 | modifySession $ \e -> e{ hsc_HPT = addToUFM (hsc_HPT e) mod mod_info } |
|---|
| 818 | return tcm |
|---|
| 819 | |
|---|
| 820 | |
|---|
| 821 | -- %************************************************************************ |
|---|
| 822 | -- %* * |
|---|
| 823 | -- Dealing with Core |
|---|
| 824 | -- %* * |
|---|
| 825 | -- %************************************************************************ |
|---|
| 826 | |
|---|
| 827 | -- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for |
|---|
| 828 | -- the 'GHC.compileToCoreModule' interface. |
|---|
| 829 | data CoreModule |
|---|
| 830 | = CoreModule { |
|---|
| 831 | -- | Module name |
|---|
| 832 | cm_module :: !Module, |
|---|
| 833 | -- | Type environment for types declared in this module |
|---|
| 834 | cm_types :: !TypeEnv, |
|---|
| 835 | -- | Declarations |
|---|
| 836 | cm_binds :: CoreProgram, |
|---|
| 837 | -- | Safe Haskell mode |
|---|
| 838 | cm_safe :: SafeHaskellMode |
|---|
| 839 | } |
|---|
| 840 | |
|---|
| 841 | instance Outputable CoreModule where |
|---|
| 842 | ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb, |
|---|
| 843 | cm_safe = sf}) |
|---|
| 844 | = text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te |
|---|
| 845 | $$ vcat (map ppr cb) |
|---|
| 846 | |
|---|
| 847 | -- | This is the way to get access to the Core bindings corresponding |
|---|
| 848 | -- to a module. 'compileToCore' parses, typechecks, and |
|---|
| 849 | -- desugars the module, then returns the resulting Core module (consisting of |
|---|
| 850 | -- the module name, type declarations, and function declarations) if |
|---|
| 851 | -- successful. |
|---|
| 852 | compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule |
|---|
| 853 | compileToCoreModule = compileCore False |
|---|
| 854 | |
|---|
| 855 | -- | Like compileToCoreModule, but invokes the simplifier, so |
|---|
| 856 | -- as to return simplified and tidied Core. |
|---|
| 857 | compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule |
|---|
| 858 | compileToCoreSimplified = compileCore True |
|---|
| 859 | {- |
|---|
| 860 | -- | Provided for backwards-compatibility: compileToCore returns just the Core |
|---|
| 861 | -- bindings, but for most purposes, you probably want to call |
|---|
| 862 | -- compileToCoreModule. |
|---|
| 863 | compileToCore :: GhcMonad m => FilePath -> m [CoreBind] |
|---|
| 864 | compileToCore fn = do |
|---|
| 865 | mod <- compileToCoreModule session fn |
|---|
| 866 | return $ cm_binds mod |
|---|
| 867 | -} |
|---|
| 868 | -- | Takes a CoreModule and compiles the bindings therein |
|---|
| 869 | -- to object code. The first argument is a bool flag indicating |
|---|
| 870 | -- whether to run the simplifier. |
|---|
| 871 | -- The resulting .o, .hi, and executable files, if any, are stored in the |
|---|
| 872 | -- current directory, and named according to the module name. |
|---|
| 873 | -- This has only so far been tested with a single self-contained module. |
|---|
| 874 | compileCoreToObj :: GhcMonad m => Bool -> CoreModule -> m () |
|---|
| 875 | compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do |
|---|
| 876 | dflags <- getSessionDynFlags |
|---|
| 877 | currentTime <- liftIO $ getCurrentTime |
|---|
| 878 | cwd <- liftIO $ getCurrentDirectory |
|---|
| 879 | modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd |
|---|
| 880 | ((moduleNameSlashes . moduleName) mName) |
|---|
| 881 | |
|---|
| 882 | let modSum = ModSummary { ms_mod = mName, |
|---|
| 883 | ms_hsc_src = ExtCoreFile, |
|---|
| 884 | ms_location = modLocation, |
|---|
| 885 | -- By setting the object file timestamp to Nothing, |
|---|
| 886 | -- we always force recompilation, which is what we |
|---|
| 887 | -- want. (Thus it doesn't matter what the timestamp |
|---|
| 888 | -- for the (nonexistent) source file is.) |
|---|
| 889 | ms_hs_date = currentTime, |
|---|
| 890 | ms_obj_date = Nothing, |
|---|
| 891 | -- Only handling the single-module case for now, so no imports. |
|---|
| 892 | ms_srcimps = [], |
|---|
| 893 | ms_textual_imps = [], |
|---|
| 894 | -- No source file |
|---|
| 895 | ms_hspp_file = "", |
|---|
| 896 | ms_hspp_opts = dflags, |
|---|
| 897 | ms_hspp_buf = Nothing |
|---|
| 898 | } |
|---|
| 899 | |
|---|
| 900 | hsc_env <- getSession |
|---|
| 901 | liftIO $ hscCompileCore hsc_env simplify (cm_safe cm) modSum (cm_binds cm) |
|---|
| 902 | |
|---|
| 903 | |
|---|
| 904 | compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule |
|---|
| 905 | compileCore simplify fn = do |
|---|
| 906 | -- First, set the target to the desired filename |
|---|
| 907 | target <- guessTarget fn Nothing |
|---|
| 908 | addTarget target |
|---|
| 909 | _ <- load LoadAllTargets |
|---|
| 910 | -- Then find dependencies |
|---|
| 911 | modGraph <- depanal [] True |
|---|
| 912 | case find ((== fn) . msHsFilePath) modGraph of |
|---|
| 913 | Just modSummary -> do |
|---|
| 914 | -- Now we have the module name; |
|---|
| 915 | -- parse, typecheck and desugar the module |
|---|
| 916 | mod_guts <- coreModule `fmap` |
|---|
| 917 | -- TODO: space leaky: call hsc* directly? |
|---|
| 918 | (desugarModule =<< typecheckModule =<< parseModule modSummary) |
|---|
| 919 | liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $ |
|---|
| 920 | if simplify |
|---|
| 921 | then do |
|---|
| 922 | -- If simplify is true: simplify (hscSimplify), then tidy |
|---|
| 923 | -- (tidyProgram). |
|---|
| 924 | hsc_env <- getSession |
|---|
| 925 | simpl_guts <- liftIO $ hscSimplify hsc_env mod_guts |
|---|
| 926 | tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts |
|---|
| 927 | return $ Left tidy_guts |
|---|
| 928 | else |
|---|
| 929 | return $ Right mod_guts |
|---|
| 930 | |
|---|
| 931 | Nothing -> panic "compileToCoreModule: target FilePath not found in\ |
|---|
| 932 | module dependency graph" |
|---|
| 933 | where -- two versions, based on whether we simplify (thus run tidyProgram, |
|---|
| 934 | -- which returns a (CgGuts, ModDetails) pair, or not (in which case |
|---|
| 935 | -- we just have a ModGuts. |
|---|
| 936 | gutsToCoreModule :: SafeHaskellMode |
|---|
| 937 | -> Either (CgGuts, ModDetails) ModGuts |
|---|
| 938 | -> CoreModule |
|---|
| 939 | gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule { |
|---|
| 940 | cm_module = cg_module cg, |
|---|
| 941 | cm_types = md_types md, |
|---|
| 942 | cm_binds = cg_binds cg, |
|---|
| 943 | cm_safe = safe_mode |
|---|
| 944 | } |
|---|
| 945 | gutsToCoreModule safe_mode (Right mg) = CoreModule { |
|---|
| 946 | cm_module = mg_module mg, |
|---|
| 947 | cm_types = typeEnvFromEntities (bindersOfBinds (mg_binds mg)) |
|---|
| 948 | (mg_tcs mg) |
|---|
| 949 | (mg_fam_insts mg), |
|---|
| 950 | cm_binds = mg_binds mg, |
|---|
| 951 | cm_safe = safe_mode |
|---|
| 952 | } |
|---|
| 953 | |
|---|
| 954 | -- %************************************************************************ |
|---|
| 955 | -- %* * |
|---|
| 956 | -- Inspecting the session |
|---|
| 957 | -- %* * |
|---|
| 958 | -- %************************************************************************ |
|---|
| 959 | |
|---|
| 960 | -- | Get the module dependency graph. |
|---|
| 961 | getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary |
|---|
| 962 | getModuleGraph = liftM hsc_mod_graph getSession |
|---|
| 963 | |
|---|
| 964 | -- | Determines whether a set of modules requires Template Haskell. |
|---|
| 965 | -- |
|---|
| 966 | -- Note that if the session's 'DynFlags' enabled Template Haskell when |
|---|
| 967 | -- 'depanal' was called, then each module in the returned module graph will |
|---|
| 968 | -- have Template Haskell enabled whether it is actually needed or not. |
|---|
| 969 | needsTemplateHaskell :: ModuleGraph -> Bool |
|---|
| 970 | needsTemplateHaskell ms = |
|---|
| 971 | any (xopt Opt_TemplateHaskell . ms_hspp_opts) ms |
|---|
| 972 | |
|---|
| 973 | -- | Return @True@ <==> module is loaded. |
|---|
| 974 | isLoaded :: GhcMonad m => ModuleName -> m Bool |
|---|
| 975 | isLoaded m = withSession $ \hsc_env -> |
|---|
| 976 | return $! isJust (lookupUFM (hsc_HPT hsc_env) m) |
|---|
| 977 | |
|---|
| 978 | -- | Return the bindings for the current interactive session. |
|---|
| 979 | getBindings :: GhcMonad m => m [TyThing] |
|---|
| 980 | getBindings = withSession $ \hsc_env -> |
|---|
| 981 | return $ icInScopeTTs $ hsc_IC hsc_env |
|---|
| 982 | |
|---|
| 983 | -- | Return the instances for the current interactive session. |
|---|
| 984 | getInsts :: GhcMonad m => m ([ClsInst], [FamInst]) |
|---|
| 985 | getInsts = withSession $ \hsc_env -> |
|---|
| 986 | return $ ic_instances (hsc_IC hsc_env) |
|---|
| 987 | |
|---|
| 988 | getPrintUnqual :: GhcMonad m => m PrintUnqualified |
|---|
| 989 | getPrintUnqual = withSession $ \hsc_env -> |
|---|
| 990 | return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env)) |
|---|
| 991 | |
|---|
| 992 | -- | Container for information about a 'Module'. |
|---|
| 993 | data ModuleInfo = ModuleInfo { |
|---|
| 994 | minf_type_env :: TypeEnv, |
|---|
| 995 | minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails? |
|---|
| 996 | minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod |
|---|
| 997 | minf_instances :: [ClsInst], |
|---|
| 998 | minf_iface :: Maybe ModIface, |
|---|
| 999 | minf_safe :: SafeHaskellMode |
|---|
| 1000 | #ifdef GHCI |
|---|
| 1001 | ,minf_modBreaks :: ModBreaks |
|---|
| 1002 | #endif |
|---|
| 1003 | } |
|---|
| 1004 | -- We don't want HomeModInfo here, because a ModuleInfo applies |
|---|
| 1005 | -- to package modules too. |
|---|
| 1006 | |
|---|
| 1007 | -- | Request information about a loaded 'Module' |
|---|
| 1008 | getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X |
|---|
| 1009 | getModuleInfo mdl = withSession $ \hsc_env -> do |
|---|
| 1010 | let mg = hsc_mod_graph hsc_env |
|---|
| 1011 | if mdl `elem` map ms_mod mg |
|---|
| 1012 | then liftIO $ getHomeModuleInfo hsc_env mdl |
|---|
| 1013 | else do |
|---|
| 1014 | {- if isHomeModule (hsc_dflags hsc_env) mdl |
|---|
| 1015 | then return Nothing |
|---|
| 1016 | else -} liftIO $ getPackageModuleInfo hsc_env mdl |
|---|
| 1017 | -- ToDo: we don't understand what the following comment means. |
|---|
| 1018 | -- (SDM, 19/7/2011) |
|---|
| 1019 | -- getPackageModuleInfo will attempt to find the interface, so |
|---|
| 1020 | -- we don't want to call it for a home module, just in case there |
|---|
| 1021 | -- was a problem loading the module and the interface doesn't |
|---|
| 1022 | -- exist... hence the isHomeModule test here. (ToDo: reinstate) |
|---|
| 1023 | |
|---|
| 1024 | getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) |
|---|
| 1025 | #ifdef GHCI |
|---|
| 1026 | getPackageModuleInfo hsc_env mdl |
|---|
| 1027 | = do eps <- hscEPS hsc_env |
|---|
| 1028 | iface <- hscGetModuleInterface hsc_env mdl |
|---|
| 1029 | let |
|---|
| 1030 | avails = mi_exports iface |
|---|
| 1031 | names = availsToNameSet avails |
|---|
| 1032 | pte = eps_PTE eps |
|---|
| 1033 | tys = [ ty | name <- concatMap availNames avails, |
|---|
| 1034 | Just ty <- [lookupTypeEnv pte name] ] |
|---|
| 1035 | -- |
|---|
| 1036 | return (Just (ModuleInfo { |
|---|
| 1037 | minf_type_env = mkTypeEnv tys, |
|---|
| 1038 | minf_exports = names, |
|---|
| 1039 | minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, |
|---|
| 1040 | minf_instances = error "getModuleInfo: instances for package module unimplemented", |
|---|
| 1041 | minf_iface = Just iface, |
|---|
| 1042 | minf_safe = getSafeMode $ mi_trust iface, |
|---|
| 1043 | minf_modBreaks = emptyModBreaks |
|---|
| 1044 | })) |
|---|
| 1045 | #else |
|---|
| 1046 | -- bogusly different for non-GHCI (ToDo) |
|---|
| 1047 | getPackageModuleInfo _hsc_env _mdl = do |
|---|
| 1048 | return Nothing |
|---|
| 1049 | #endif |
|---|
| 1050 | |
|---|
| 1051 | getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) |
|---|
| 1052 | getHomeModuleInfo hsc_env mdl = |
|---|
| 1053 | case lookupUFM (hsc_HPT hsc_env) (moduleName mdl) of |
|---|
| 1054 | Nothing -> return Nothing |
|---|
| 1055 | Just hmi -> do |
|---|
| 1056 | let details = hm_details hmi |
|---|
| 1057 | iface = hm_iface hmi |
|---|
| 1058 | return (Just (ModuleInfo { |
|---|
| 1059 | minf_type_env = md_types details, |
|---|
| 1060 | minf_exports = availsToNameSet (md_exports details), |
|---|
| 1061 | minf_rdr_env = mi_globals $! hm_iface hmi, |
|---|
| 1062 | minf_instances = md_insts details, |
|---|
| 1063 | minf_iface = Just iface, |
|---|
| 1064 | minf_safe = getSafeMode $ mi_trust iface |
|---|
| 1065 | #ifdef GHCI |
|---|
| 1066 | ,minf_modBreaks = getModBreaks hmi |
|---|
| 1067 | #endif |
|---|
| 1068 | })) |
|---|
| 1069 | |
|---|
| 1070 | -- | The list of top-level entities defined in a module |
|---|
| 1071 | modInfoTyThings :: ModuleInfo -> [TyThing] |
|---|
| 1072 | modInfoTyThings minf = typeEnvElts (minf_type_env minf) |
|---|
| 1073 | |
|---|
| 1074 | modInfoTopLevelScope :: ModuleInfo -> Maybe [Name] |
|---|
| 1075 | modInfoTopLevelScope minf |
|---|
| 1076 | = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf) |
|---|
| 1077 | |
|---|
| 1078 | modInfoExports :: ModuleInfo -> [Name] |
|---|
| 1079 | modInfoExports minf = nameSetToList $! minf_exports minf |
|---|
| 1080 | |
|---|
| 1081 | -- | Returns the instances defined by the specified module. |
|---|
| 1082 | -- Warning: currently unimplemented for package modules. |
|---|
| 1083 | modInfoInstances :: ModuleInfo -> [ClsInst] |
|---|
| 1084 | modInfoInstances = minf_instances |
|---|
| 1085 | |
|---|
| 1086 | modInfoIsExportedName :: ModuleInfo -> Name -> Bool |
|---|
| 1087 | modInfoIsExportedName minf name = elemNameSet name (minf_exports minf) |
|---|
| 1088 | |
|---|
| 1089 | mkPrintUnqualifiedForModule :: GhcMonad m => |
|---|
| 1090 | ModuleInfo |
|---|
| 1091 | -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X |
|---|
| 1092 | mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do |
|---|
| 1093 | return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf)) |
|---|
| 1094 | |
|---|
| 1095 | modInfoLookupName :: GhcMonad m => |
|---|
| 1096 | ModuleInfo -> Name |
|---|
| 1097 | -> m (Maybe TyThing) -- XXX: returns a Maybe X |
|---|
| 1098 | modInfoLookupName minf name = withSession $ \hsc_env -> do |
|---|
| 1099 | case lookupTypeEnv (minf_type_env minf) name of |
|---|
| 1100 | Just tyThing -> return (Just tyThing) |
|---|
| 1101 | Nothing -> do |
|---|
| 1102 | eps <- liftIO $ readIORef (hsc_EPS hsc_env) |
|---|
| 1103 | return $! lookupType (hsc_dflags hsc_env) |
|---|
| 1104 | (hsc_HPT hsc_env) (eps_PTE eps) name |
|---|
| 1105 | |
|---|
| 1106 | modInfoIface :: ModuleInfo -> Maybe ModIface |
|---|
| 1107 | modInfoIface = minf_iface |
|---|
| 1108 | |
|---|
| 1109 | -- | Retrieve module safe haskell mode |
|---|
| 1110 | modInfoSafe :: ModuleInfo -> SafeHaskellMode |
|---|
| 1111 | modInfoSafe = minf_safe |
|---|
| 1112 | |
|---|
| 1113 | #ifdef GHCI |
|---|
| 1114 | modInfoModBreaks :: ModuleInfo -> ModBreaks |
|---|
| 1115 | modInfoModBreaks = minf_modBreaks |
|---|
| 1116 | #endif |
|---|
| 1117 | |
|---|
| 1118 | isDictonaryId :: Id -> Bool |
|---|
| 1119 | isDictonaryId id |
|---|
| 1120 | = case tcSplitSigmaTy (idType id) of { (_tvs, _theta, tau) -> isDictTy tau } |
|---|
| 1121 | |
|---|
| 1122 | -- | Looks up a global name: that is, any top-level name in any |
|---|
| 1123 | -- visible module. Unlike 'lookupName', lookupGlobalName does not use |
|---|
| 1124 | -- the interactive context, and therefore does not require a preceding |
|---|
| 1125 | -- 'setContext'. |
|---|
| 1126 | lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing) |
|---|
| 1127 | lookupGlobalName name = withSession $ \hsc_env -> do |
|---|
| 1128 | liftIO $ lookupTypeHscEnv hsc_env name |
|---|
| 1129 | |
|---|
| 1130 | findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a] |
|---|
| 1131 | findGlobalAnns deserialize target = withSession $ \hsc_env -> do |
|---|
| 1132 | ann_env <- liftIO $ prepareAnnotations hsc_env Nothing |
|---|
| 1133 | return (findAnns deserialize ann_env target) |
|---|
| 1134 | |
|---|
| 1135 | #ifdef GHCI |
|---|
| 1136 | -- | get the GlobalRdrEnv for a session |
|---|
| 1137 | getGRE :: GhcMonad m => m GlobalRdrEnv |
|---|
| 1138 | getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env) |
|---|
| 1139 | #endif |
|---|
| 1140 | |
|---|
| 1141 | -- ----------------------------------------------------------------------------- |
|---|
| 1142 | |
|---|
| 1143 | -- | Return all /external/ modules available in the package database. |
|---|
| 1144 | -- Modules from the current session (i.e., from the 'HomePackageTable') are |
|---|
| 1145 | -- not included. |
|---|
| 1146 | packageDbModules :: GhcMonad m => |
|---|
| 1147 | Bool -- ^ Only consider exposed packages. |
|---|
| 1148 | -> m [Module] |
|---|
| 1149 | packageDbModules only_exposed = do |
|---|
| 1150 | dflags <- getSessionDynFlags |
|---|
| 1151 | let pkgs = eltsUFM (pkgIdMap (pkgState dflags)) |
|---|
| 1152 | return $ |
|---|
| 1153 | [ mkModule pid modname | p <- pkgs |
|---|
| 1154 | , not only_exposed || exposed p |
|---|
| 1155 | , let pid = packageConfigId p |
|---|
| 1156 | , modname <- exposedModules p ] |
|---|
| 1157 | |
|---|
| 1158 | -- ----------------------------------------------------------------------------- |
|---|
| 1159 | -- Misc exported utils |
|---|
| 1160 | |
|---|
| 1161 | dataConType :: DataCon -> Type |
|---|
| 1162 | dataConType dc = idType (dataConWrapId dc) |
|---|
| 1163 | |
|---|
| 1164 | -- | print a 'NamedThing', adding parentheses if the name is an operator. |
|---|
| 1165 | pprParenSymName :: NamedThing a => a -> SDoc |
|---|
| 1166 | pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a)) |
|---|
| 1167 | |
|---|
| 1168 | -- ---------------------------------------------------------------------------- |
|---|
| 1169 | |
|---|
| 1170 | #if 0 |
|---|
| 1171 | |
|---|
| 1172 | -- ToDo: |
|---|
| 1173 | -- - Data and Typeable instances for HsSyn. |
|---|
| 1174 | |
|---|
| 1175 | -- ToDo: check for small transformations that happen to the syntax in |
|---|
| 1176 | -- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral) |
|---|
| 1177 | |
|---|
| 1178 | -- ToDo: maybe use TH syntax instead of IfaceSyn? There's already a way |
|---|
| 1179 | -- to get from TyCons, Ids etc. to TH syntax (reify). |
|---|
| 1180 | |
|---|
| 1181 | -- :browse will use either lm_toplev or inspect lm_interface, depending |
|---|
| 1182 | -- on whether the module is interpreted or not. |
|---|
| 1183 | |
|---|
| 1184 | #endif |
|---|
| 1185 | |
|---|
| 1186 | -- Extract the filename, stringbuffer content and dynflags associed to a module |
|---|
| 1187 | -- |
|---|
| 1188 | -- XXX: Explain pre-conditions |
|---|
| 1189 | getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags) |
|---|
| 1190 | getModuleSourceAndFlags mod = do |
|---|
| 1191 | m <- getModSummary (moduleName mod) |
|---|
| 1192 | case ml_hs_file $ ms_location m of |
|---|
| 1193 | Nothing -> throw $ mkApiErr (text "No source available for module " <+> ppr mod) |
|---|
| 1194 | Just sourceFile -> do |
|---|
| 1195 | source <- liftIO $ hGetStringBuffer sourceFile |
|---|
| 1196 | return (sourceFile, source, ms_hspp_opts m) |
|---|
| 1197 | |
|---|
| 1198 | |
|---|
| 1199 | -- | Return module source as token stream, including comments. |
|---|
| 1200 | -- |
|---|
| 1201 | -- The module must be in the module graph and its source must be available. |
|---|
| 1202 | -- Throws a 'HscTypes.SourceError' on parse error. |
|---|
| 1203 | getTokenStream :: GhcMonad m => Module -> m [Located Token] |
|---|
| 1204 | getTokenStream mod = do |
|---|
| 1205 | (sourceFile, source, flags) <- getModuleSourceAndFlags mod |
|---|
| 1206 | let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 |
|---|
| 1207 | case lexTokenStream source startLoc flags of |
|---|
| 1208 | POk _ ts -> return ts |
|---|
| 1209 | PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err) |
|---|
| 1210 | |
|---|
| 1211 | -- | Give even more information on the source than 'getTokenStream' |
|---|
| 1212 | -- This function allows reconstructing the source completely with |
|---|
| 1213 | -- 'showRichTokenStream'. |
|---|
| 1214 | getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)] |
|---|
| 1215 | getRichTokenStream mod = do |
|---|
| 1216 | (sourceFile, source, flags) <- getModuleSourceAndFlags mod |
|---|
| 1217 | let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 |
|---|
| 1218 | case lexTokenStream source startLoc flags of |
|---|
| 1219 | POk _ ts -> return $ addSourceToTokens startLoc source ts |
|---|
| 1220 | PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err) |
|---|
| 1221 | |
|---|
| 1222 | -- | Given a source location and a StringBuffer corresponding to this |
|---|
| 1223 | -- location, return a rich token stream with the source associated to the |
|---|
| 1224 | -- tokens. |
|---|
| 1225 | addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token] |
|---|
| 1226 | -> [(Located Token, String)] |
|---|
| 1227 | addSourceToTokens _ _ [] = [] |
|---|
| 1228 | addSourceToTokens loc buf (t@(L span _) : ts) |
|---|
| 1229 | = case span of |
|---|
| 1230 | UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts |
|---|
| 1231 | RealSrcSpan s -> (t,str) : addSourceToTokens newLoc newBuf ts |
|---|
| 1232 | where |
|---|
| 1233 | (newLoc, newBuf, str) = go "" loc buf |
|---|
| 1234 | start = realSrcSpanStart s |
|---|
| 1235 | end = realSrcSpanEnd s |
|---|
| 1236 | go acc loc buf | loc < start = go acc nLoc nBuf |
|---|
| 1237 | | start <= loc && loc < end = go (ch:acc) nLoc nBuf |
|---|
| 1238 | | otherwise = (loc, buf, reverse acc) |
|---|
| 1239 | where (ch, nBuf) = nextChar buf |
|---|
| 1240 | nLoc = advanceSrcLoc loc ch |
|---|
| 1241 | |
|---|
| 1242 | |
|---|
| 1243 | -- | Take a rich token stream such as produced from 'getRichTokenStream' and |
|---|
| 1244 | -- return source code almost identical to the original code (except for |
|---|
| 1245 | -- insignificant whitespace.) |
|---|
| 1246 | showRichTokenStream :: [(Located Token, String)] -> String |
|---|
| 1247 | showRichTokenStream ts = go startLoc ts "" |
|---|
| 1248 | where sourceFile = getFile $ map (getLoc . fst) ts |
|---|
| 1249 | getFile [] = panic "showRichTokenStream: No source file found" |
|---|
| 1250 | getFile (UnhelpfulSpan _ : xs) = getFile xs |
|---|
| 1251 | getFile (RealSrcSpan s : _) = srcSpanFile s |
|---|
| 1252 | startLoc = mkRealSrcLoc sourceFile 1 1 |
|---|
| 1253 | go _ [] = id |
|---|
| 1254 | go loc ((L span _, str):ts) |
|---|
| 1255 | = case span of |
|---|
| 1256 | UnhelpfulSpan _ -> go loc ts |
|---|
| 1257 | RealSrcSpan s |
|---|
| 1258 | | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++) |
|---|
| 1259 | . (str ++) |
|---|
| 1260 | . go tokEnd ts |
|---|
| 1261 | | otherwise -> ((replicate (tokLine - locLine) '\n') ++) |
|---|
| 1262 | . ((replicate tokCol ' ') ++) |
|---|
| 1263 | . (str ++) |
|---|
| 1264 | . go tokEnd ts |
|---|
| 1265 | where (locLine, locCol) = (srcLocLine loc, srcLocCol loc) |
|---|
| 1266 | (tokLine, tokCol) = (srcSpanStartLine s, srcSpanStartCol s) |
|---|
| 1267 | tokEnd = realSrcSpanEnd s |
|---|
| 1268 | |
|---|
| 1269 | -- ----------------------------------------------------------------------------- |
|---|
| 1270 | -- Interactive evaluation |
|---|
| 1271 | |
|---|
| 1272 | -- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the |
|---|
| 1273 | -- filesystem and package database to find the corresponding 'Module', |
|---|
| 1274 | -- using the algorithm that is used for an @import@ declaration. |
|---|
| 1275 | findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module |
|---|
| 1276 | findModule mod_name maybe_pkg = withSession $ \hsc_env -> do |
|---|
| 1277 | let |
|---|
| 1278 | dflags = hsc_dflags hsc_env |
|---|
| 1279 | this_pkg = thisPackage dflags |
|---|
| 1280 | -- |
|---|
| 1281 | case maybe_pkg of |
|---|
| 1282 | Just pkg | fsToPackageId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do |
|---|
| 1283 | res <- findImportedModule hsc_env mod_name maybe_pkg |
|---|
| 1284 | case res of |
|---|
| 1285 | Found _ m -> return m |
|---|
| 1286 | err -> noModError dflags noSrcSpan mod_name err |
|---|
| 1287 | _otherwise -> do |
|---|
| 1288 | home <- lookupLoadedHomeModule mod_name |
|---|
| 1289 | case home of |
|---|
| 1290 | Just m -> return m |
|---|
| 1291 | Nothing -> liftIO $ do |
|---|
| 1292 | res <- findImportedModule hsc_env mod_name maybe_pkg |
|---|
| 1293 | case res of |
|---|
| 1294 | Found loc m | modulePackageId m /= this_pkg -> return m |
|---|
| 1295 | | otherwise -> modNotLoadedError m loc |
|---|
| 1296 | err -> noModError dflags noSrcSpan mod_name err |
|---|
| 1297 | |
|---|
| 1298 | modNotLoadedError :: Module -> ModLocation -> IO a |
|---|
| 1299 | modNotLoadedError m loc = ghcError $ CmdLineError $ showSDoc $ |
|---|
| 1300 | text "module is not loaded:" <+> |
|---|
| 1301 | quotes (ppr (moduleName m)) <+> |
|---|
| 1302 | parens (text (expectJust "modNotLoadedError" (ml_hs_file loc))) |
|---|
| 1303 | |
|---|
| 1304 | -- | Like 'findModule', but differs slightly when the module refers to |
|---|
| 1305 | -- a source file, and the file has not been loaded via 'load'. In |
|---|
| 1306 | -- this case, 'findModule' will throw an error (module not loaded), |
|---|
| 1307 | -- but 'lookupModule' will check to see whether the module can also be |
|---|
| 1308 | -- found in a package, and if so, that package 'Module' will be |
|---|
| 1309 | -- returned. If not, the usual module-not-found error will be thrown. |
|---|
| 1310 | -- |
|---|
| 1311 | lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module |
|---|
| 1312 | lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg) |
|---|
| 1313 | lookupModule mod_name Nothing = withSession $ \hsc_env -> do |
|---|
| 1314 | home <- lookupLoadedHomeModule mod_name |
|---|
| 1315 | case home of |
|---|
| 1316 | Just m -> return m |
|---|
| 1317 | Nothing -> liftIO $ do |
|---|
| 1318 | res <- findExposedPackageModule hsc_env mod_name Nothing |
|---|
| 1319 | case res of |
|---|
| 1320 | Found _ m -> return m |
|---|
| 1321 | err -> noModError (hsc_dflags hsc_env) noSrcSpan mod_name err |
|---|
| 1322 | |
|---|
| 1323 | lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module) |
|---|
| 1324 | lookupLoadedHomeModule mod_name = withSession $ \hsc_env -> |
|---|
| 1325 | case lookupUFM (hsc_HPT hsc_env) mod_name of |
|---|
| 1326 | Just mod_info -> return (Just (mi_module (hm_iface mod_info))) |
|---|
| 1327 | _not_a_home_module -> return Nothing |
|---|
| 1328 | |
|---|
| 1329 | #ifdef GHCI |
|---|
| 1330 | -- | Check that a module is safe to import (according to Safe Haskell). |
|---|
| 1331 | -- |
|---|
| 1332 | -- We return True to indicate the import is safe and False otherwise |
|---|
| 1333 | -- although in the False case an error may be thrown first. |
|---|
| 1334 | isModuleTrusted :: GhcMonad m => Module -> m Bool |
|---|
| 1335 | isModuleTrusted m = withSession $ \hsc_env -> |
|---|
| 1336 | liftIO $ hscCheckSafe hsc_env m noSrcSpan |
|---|
| 1337 | |
|---|
| 1338 | -- | EXPERIMENTAL: DO NOT USE. |
|---|
| 1339 | -- |
|---|
| 1340 | -- Set the monad GHCi lifts user statements into. |
|---|
| 1341 | -- |
|---|
| 1342 | -- Checks that a type (in string form) is an instance of the |
|---|
| 1343 | -- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is, |
|---|
| 1344 | -- throws an error otherwise. |
|---|
| 1345 | {-# WARNING setGHCiMonad "This is experimental! Don't use." #-} |
|---|
| 1346 | setGHCiMonad :: GhcMonad m => String -> m () |
|---|
| 1347 | setGHCiMonad name = withSession $ \hsc_env -> do |
|---|
| 1348 | ty <- liftIO $ hscIsGHCiMonad hsc_env name |
|---|
| 1349 | modifySession $ \s -> |
|---|
| 1350 | let ic = (hsc_IC s) { ic_monad = ty } |
|---|
| 1351 | in s { hsc_IC = ic } |
|---|
| 1352 | |
|---|
| 1353 | getHistorySpan :: GhcMonad m => History -> m SrcSpan |
|---|
| 1354 | getHistorySpan h = withSession $ \hsc_env -> |
|---|
| 1355 | return $ InteractiveEval.getHistorySpan hsc_env h |
|---|
| 1356 | |
|---|
| 1357 | obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term |
|---|
| 1358 | obtainTermFromVal bound force ty a = withSession $ \hsc_env -> |
|---|
| 1359 | liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a |
|---|
| 1360 | |
|---|
| 1361 | obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term |
|---|
| 1362 | obtainTermFromId bound force id = withSession $ \hsc_env -> |
|---|
| 1363 | liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id |
|---|
| 1364 | |
|---|
| 1365 | #endif |
|---|
| 1366 | |
|---|
| 1367 | -- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any |
|---|
| 1368 | -- entity known to GHC, including 'Name's defined using 'runStmt'. |
|---|
| 1369 | lookupName :: GhcMonad m => Name -> m (Maybe TyThing) |
|---|
| 1370 | lookupName name = |
|---|
| 1371 | withSession $ \hsc_env -> |
|---|
| 1372 | liftIO $ hscTcRcLookupName hsc_env name |
|---|
| 1373 | |
|---|
| 1374 | -- ----------------------------------------------------------------------------- |
|---|
| 1375 | -- Pure API |
|---|
| 1376 | |
|---|
| 1377 | -- | A pure interface to the module parser. |
|---|
| 1378 | -- |
|---|
| 1379 | parser :: String -- ^ Haskell module source text (full Unicode is supported) |
|---|
| 1380 | -> DynFlags -- ^ the flags |
|---|
| 1381 | -> FilePath -- ^ the filename (for source locations) |
|---|
| 1382 | -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName)) |
|---|
| 1383 | |
|---|
| 1384 | parser str dflags filename = |
|---|
| 1385 | let |
|---|
| 1386 | loc = mkRealSrcLoc (mkFastString filename) 1 1 |
|---|
| 1387 | buf = stringToStringBuffer str |
|---|
| 1388 | in |
|---|
| 1389 | case unP Parser.parseModule (mkPState dflags buf loc) of |
|---|
| 1390 | |
|---|
| 1391 | PFailed span err -> |
|---|
| 1392 | Left (unitBag (mkPlainErrMsg span err)) |
|---|
| 1393 | |
|---|
| 1394 | POk pst rdr_module -> |
|---|
| 1395 | let (warns,_) = getMessages pst in |
|---|
| 1396 | Right (warns, rdr_module) |
|---|