diff options
Diffstat (limited to 'compiler/main/GHC.hs')
| -rw-r--r-- | compiler/main/GHC.hs | 1705 |
1 files changed, 0 insertions, 1705 deletions
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs deleted file mode 100644 index b15803eed1..0000000000 --- a/compiler/main/GHC.hs +++ /dev/null @@ -1,1705 +0,0 @@ -{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables #-} -{-# LANGUAGE TupleSections, NamedFieldPuns #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} - --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2005-2012 --- --- The GHC API --- --- ----------------------------------------------------------------------------- - -module GHC ( - -- * Initialisation - defaultErrorHandler, - defaultCleanupHandler, - prettyPrintGhcErrors, - withSignalHandlers, - withCleanupSession, - - -- * GHC Monad - Ghc, GhcT, GhcMonad(..), HscEnv, - runGhc, runGhcT, initGhcMonad, - gcatch, gbracket, gfinally, - printException, - handleSourceError, - needsTemplateHaskellOrQQ, - - -- * Flags and settings - DynFlags(..), GeneralFlag(..), Severity(..), HscTarget(..), gopt, - GhcMode(..), GhcLink(..), defaultObjectTarget, - parseDynamicFlags, - getSessionDynFlags, setSessionDynFlags, - getProgramDynFlags, setProgramDynFlags, setLogAction, - getInteractiveDynFlags, setInteractiveDynFlags, - interpretPackageEnv, - - -- * Targets - Target(..), TargetId(..), Phase, - setTargets, - getTargets, - addTarget, - removeTarget, - guessTarget, - - -- * Loading\/compiling the program - depanal, depanalE, - load, LoadHowMuch(..), InteractiveImport(..), - SuccessFlag(..), succeeded, failed, - defaultWarnErrLogger, WarnErrLogger, - workingDirectoryChanged, - parseModule, typecheckModule, desugarModule, loadModule, - ParsedModule(..), TypecheckedModule(..), DesugaredModule(..), - TypecheckedSource, ParsedSource, RenamedSource, -- ditto - TypecheckedMod, ParsedMod, - moduleInfo, renamedSource, typecheckedSource, - parsedSource, coreModule, - - -- ** Compiling to Core - CoreModule(..), - compileToCoreModule, compileToCoreSimplified, - - -- * Inspecting the module structure of the program - ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries, - mgLookupModule, - ModSummary(..), ms_mod_name, ModLocation(..), - getModSummary, - getModuleGraph, - isLoaded, - topSortModuleGraph, - - -- * Inspecting modules - ModuleInfo, - getModuleInfo, - modInfoTyThings, - modInfoTopLevelScope, - modInfoExports, - modInfoExportsWithSelectors, - modInfoInstances, - modInfoIsExportedName, - modInfoLookupName, - modInfoIface, - modInfoRdrEnv, - modInfoSafe, - lookupGlobalName, - findGlobalAnns, - mkPrintUnqualifiedForModule, - ModIface, ModIface_(..), - SafeHaskellMode(..), - - -- * Querying the environment - -- packageDbModules, - - -- * Printing - PrintUnqualified, alwaysQualify, - - -- * Interactive evaluation - - -- ** Executing statements - execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..), - resumeExec, - - -- ** Adding new declarations - runDecls, runDeclsWithLocation, runParsedDecls, - - -- ** Get/set the current context - parseImportDecl, - setContext, getContext, - setGHCiMonad, getGHCiMonad, - - -- ** Inspecting the current context - getBindings, getInsts, getPrintUnqual, - findModule, lookupModule, - isModuleTrusted, moduleTrustReqs, - getNamesInScope, - getRdrNamesInScope, - getGRE, - moduleIsInterpreted, - getInfo, - showModule, - moduleIsBootOrNotObjectLinkable, - getNameToInstancesIndex, - - -- ** Inspecting types and kinds - exprType, TcRnExprMode(..), - typeKind, - - -- ** Looking up a Name - parseName, - lookupName, - - -- ** Compiling expressions - HValue, parseExpr, compileParsedExpr, - GHC.Runtime.Eval.compileExpr, dynCompileExpr, - ForeignHValue, - compileExprRemote, compileParsedExprRemote, - - -- ** Docs - getDocs, GetDocsFailure(..), - - -- ** Other - runTcInteractive, -- Desired by some clients (#8878) - isStmt, hasImport, isImport, isDecl, - - -- ** The debugger - SingleStep(..), - Resume(..), - History(historyBreakInfo, historyEnclosingDecls), - GHC.getHistorySpan, getHistoryModule, - abandon, abandonAll, - getResumeContext, - GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType, - modInfoModBreaks, - ModBreaks(..), BreakIndex, - BreakInfo(breakInfo_number, breakInfo_module), - GHC.Runtime.Eval.back, - GHC.Runtime.Eval.forward, - - -- * Abstract syntax elements - - -- ** Packages - UnitId, - - -- ** Modules - Module, mkModule, pprModule, moduleName, moduleUnitId, - ModuleName, mkModuleName, moduleNameString, - - -- ** Names - Name, - isExternalName, nameModule, pprParenSymName, nameSrcSpan, - NamedThing(..), - RdrName(Qual,Unqual), - - -- ** Identifiers - Id, idType, - isImplicitId, isDeadBinder, - isExportedId, isLocalId, isGlobalId, - isRecordSelector, - isPrimOpId, isFCallId, isClassOpId_maybe, - isDataConWorkId, idDataCon, - isBottomingId, isDictonaryId, - recordSelectorTyCon, - - -- ** Type constructors - TyCon, - tyConTyVars, tyConDataCons, tyConArity, - isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon, - isPrimTyCon, isFunTyCon, - isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon, - tyConClass_maybe, - synTyConRhs_maybe, synTyConDefn_maybe, tyConKind, - - -- ** Type variables - TyVar, - alphaTyVars, - - -- ** Data constructors - DataCon, - dataConType, dataConTyCon, dataConFieldLabels, - dataConIsInfix, isVanillaDataCon, dataConUserType, - dataConSrcBangs, - StrictnessMark(..), isMarkedStrict, - - -- ** Classes - Class, - classMethods, classSCTheta, classTvsFds, classATs, - pprFundeps, - - -- ** Instances - ClsInst, - instanceDFunId, - pprInstance, pprInstanceHdr, - pprFamInst, - - FamInst, - - -- ** Types and Kinds - Type, splitForAllTys, funResultTy, - pprParendType, pprTypeApp, - Kind, - PredType, - ThetaType, pprForAll, pprThetaArrowTy, - parseInstanceHead, - getInstancesForType, - - -- ** Entities - TyThing(..), - - -- ** Syntax - module GHC.Hs, -- ToDo: remove extraneous bits - - -- ** Fixities - FixityDirection(..), - defaultFixity, maxPrecedence, - negateFixity, - compareFixity, - LexicalFixity(..), - - -- ** Source locations - SrcLoc(..), RealSrcLoc, - mkSrcLoc, noSrcLoc, - srcLocFile, srcLocLine, srcLocCol, - SrcSpan(..), RealSrcSpan, - mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan, - srcSpanStart, srcSpanEnd, - srcSpanFile, - srcSpanStartLine, srcSpanEndLine, - srcSpanStartCol, srcSpanEndCol, - - -- ** Located - GenLocated(..), Located, - - -- *** Constructing Located - noLoc, mkGeneralLocated, - - -- *** Deconstructing Located - getLoc, unLoc, - getRealSrcSpan, unRealSrcSpan, - - -- *** Combining and comparing Located values - eqLocated, cmpLocated, combineLocs, addCLoc, - leftmost_smallest, leftmost_largest, rightmost, - spans, isSubspanOf, - - -- * Exceptions - GhcException(..), showGhcException, - - -- * Token stream manipulations - Token, - getTokenStream, getRichTokenStream, - showRichTokenStream, addSourceToTokens, - - -- * Pure interface to the parser - parser, - - -- * API Annotations - ApiAnns(..),AnnKeywordId(..),AnnotationComment(..), - getAnnotation, getAndRemoveAnnotation, - getAnnotationComments, getAndRemoveAnnotationComments, - unicodeAnn, - - -- * Miscellaneous - --sessionHscEnv, - cyclicModuleErr, - ) where - -{- - ToDo: - - * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt. --} - -#include "HsVersions.h" - -import GhcPrelude hiding (init) - -import GHC.ByteCode.Types -import GHC.Runtime.Eval -import GHC.Runtime.Eval.Types -import GHC.Runtime.Interpreter -import GHCi.RemoteTypes - -import PprTyThing ( pprFamInst ) -import HscMain -import GhcMake -import DriverPipeline ( compileOne' ) -import GhcMonad -import TcRnMonad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) -import GHC.Iface.Load ( loadSysInterface ) -import TcRnTypes -import Predicate -import Packages -import NameSet -import RdrName -import GHC.Hs -import Type hiding( typeKind ) -import TcType -import Id -import TysPrim ( alphaTyVars ) -import TyCon -import TyCoPpr ( pprForAll ) -import Class -import DataCon -import Name hiding ( varName ) -import Avail -import InstEnv -import FamInstEnv ( FamInst ) -import SrcLoc -import CoreSyn -import GHC.Iface.Tidy -import DriverPhases ( Phase(..), isHaskellSrcFilename ) -import Finder -import HscTypes -import CmdLineParser -import DynFlags hiding (WarnReason(..)) -import SysTools -import SysTools.BaseDir -import Annotations -import Module -import Panic -import GHC.Platform -import Bag ( listToBag ) -import ErrUtils -import MonadUtils -import Util -import StringBuffer -import Outputable -import BasicTypes -import FastString -import qualified Parser -import Lexer -import ApiAnnotation -import qualified GHC.LanguageExtensions as LangExt -import NameEnv -import CoreFVs ( orphNamesOfFamInst ) -import FamInstEnv ( famInstEnvElts ) -import TcRnDriver -import Inst -import FamInst -import FileCleanup - -import Data.Foldable -import qualified Data.Map.Strict as Map -import Data.Set (Set) -import qualified Data.Sequence as Seq -import Data.Maybe -import Data.Time -import Data.Typeable ( Typeable ) -import Data.Word ( Word8 ) -import Control.Monad -import System.Exit ( exitWith, ExitCode(..) ) -import Exception -import Data.IORef -import System.FilePath - -import Maybes -import System.IO.Error ( isDoesNotExistError ) -import System.Environment ( getEnv ) -import System.Directory - - --- %************************************************************************ --- %* * --- Initialisation: exception handlers --- %* * --- %************************************************************************ - - --- | Install some default exception handlers and run the inner computation. --- Unless you want to handle exceptions yourself, you should wrap this around --- the top level of your program. The default handlers output the error --- message(s) to stderr and exit cleanly. -defaultErrorHandler :: (ExceptionMonad m) - => FatalMessager -> FlushOut -> m a -> m a -defaultErrorHandler fm (FlushOut flushOut) inner = - -- top-level exception handler: any unrecognised exception is a compiler bug. - ghandle (\exception -> liftIO $ do - flushOut - case fromException exception of - -- an IO exception probably isn't our fault, so don't panic - Just (ioe :: IOException) -> - fatalErrorMsg'' fm (show ioe) - _ -> case fromException exception of - Just UserInterrupt -> - -- Important to let this one propagate out so our - -- calling process knows we were interrupted by ^C - liftIO $ throwIO UserInterrupt - Just StackOverflow -> - fatalErrorMsg'' fm "stack overflow: use +RTS -K<size> to increase it" - _ -> case fromException exception of - Just (ex :: ExitCode) -> liftIO $ throwIO ex - _ -> - fatalErrorMsg'' fm - (show (Panic (show exception))) - exitWith (ExitFailure 1) - ) $ - - -- error messages propagated as exceptions - handleGhcException - (\ge -> liftIO $ do - flushOut - case ge of - Signal _ -> exitWith (ExitFailure 1) - _ -> do fatalErrorMsg'' fm (show ge) - exitWith (ExitFailure 1) - ) $ - inner - --- | This function is no longer necessary, cleanup is now done by --- runGhc/runGhcT. -{-# DEPRECATED defaultCleanupHandler "Cleanup is now done by runGhc/runGhcT" #-} -defaultCleanupHandler :: (ExceptionMonad m) => DynFlags -> m a -> m a -defaultCleanupHandler _ m = m - where _warning_suppression = m `gonException` undefined - - --- %************************************************************************ --- %* * --- The Ghc Monad --- %* * --- %************************************************************************ - --- | Run function for the 'Ghc' monad. --- --- It initialises the GHC session and warnings via 'initGhcMonad'. Each call --- to this function will create a new session which should not be shared among --- several threads. --- --- Any errors not handled inside the 'Ghc' action are propagated as IO --- exceptions. - -runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'. - -> Ghc a -- ^ The action to perform. - -> IO a -runGhc mb_top_dir ghc = do - ref <- newIORef (panic "empty session") - let session = Session ref - flip unGhc session $ withSignalHandlers $ do -- catch ^C - initGhcMonad mb_top_dir - withCleanupSession ghc - --- | Run function for 'GhcT' monad transformer. --- --- It initialises the GHC session and warnings via 'initGhcMonad'. Each call --- to this function will create a new session which should not be shared among --- several threads. - -runGhcT :: ExceptionMonad m => - Maybe FilePath -- ^ See argument to 'initGhcMonad'. - -> GhcT m a -- ^ The action to perform. - -> m a -runGhcT mb_top_dir ghct = do - ref <- liftIO $ newIORef (panic "empty session") - let session = Session ref - flip unGhcT session $ withSignalHandlers $ do -- catch ^C - initGhcMonad mb_top_dir - withCleanupSession ghct - -withCleanupSession :: GhcMonad m => m a -> m a -withCleanupSession ghc = ghc `gfinally` cleanup - where - cleanup = do - hsc_env <- getSession - let dflags = hsc_dflags hsc_env - liftIO $ do - cleanTempFiles dflags - cleanTempDirs dflags - stopIServ hsc_env -- shut down the IServ - -- exceptions will be blocked while we clean the temporary files, - -- so there shouldn't be any difficulty if we receive further - -- signals. - --- | Initialise a GHC session. --- --- If you implement a custom 'GhcMonad' you must call this function in the --- monad run function. It will initialise the session variable and clear all --- warnings. --- --- The first argument should point to the directory where GHC's library files --- reside. More precisely, this should be the output of @ghc --print-libdir@ --- of the version of GHC the module using this API is compiled with. For --- portability, you should use the @ghc-paths@ package, available at --- <http://hackage.haskell.org/package/ghc-paths>. - -initGhcMonad :: GhcMonad m => Maybe FilePath -> m () -initGhcMonad mb_top_dir - = do { env <- liftIO $ - do { top_dir <- findTopDir mb_top_dir - ; mySettings <- initSysTools top_dir - ; myLlvmConfig <- lazyInitLlvmConfig top_dir - ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig) - ; checkBrokenTablesNextToCode dflags - ; setUnsafeGlobalDynFlags dflags - -- c.f. DynFlags.parseDynamicFlagsFull, which - -- creates DynFlags and sets the UnsafeGlobalDynFlags - ; newHscEnv dflags } - ; setSession env } - --- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which --- breaks tables-next-to-code in dynamically linked modules. This --- check should be more selective but there is currently no released --- version where this bug is fixed. --- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and --- https://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333 -checkBrokenTablesNextToCode :: MonadIO m => DynFlags -> m () -checkBrokenTablesNextToCode dflags - = do { broken <- checkBrokenTablesNextToCode' dflags - ; when broken - $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr - ; liftIO $ fail "unsupported linker" - } - } - where - invalidLdErr = text "Tables-next-to-code not supported on ARM" <+> - text "when using binutils ld (please see:" <+> - text "https://sourceware.org/bugzilla/show_bug.cgi?id=16177)" - -checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool -checkBrokenTablesNextToCode' dflags - | not (isARM arch) = return False - | WayDyn `notElem` ways dflags = return False - | not (tablesNextToCode dflags) = return False - | otherwise = do - linkerInfo <- liftIO $ getLinkerInfo dflags - case linkerInfo of - GnuLD _ -> return True - _ -> return False - where platform = targetPlatform dflags - arch = platformArch platform - - --- %************************************************************************ --- %* * --- Flags & settings --- %* * --- %************************************************************************ - --- $DynFlags --- --- The GHC session maintains two sets of 'DynFlags': --- --- * The "interactive" @DynFlags@, which are used for everything --- related to interactive evaluation, including 'runStmt', --- 'runDecls', 'exprType', 'lookupName' and so on (everything --- under \"Interactive evaluation\" in this module). --- --- * The "program" @DynFlags@, which are used when loading --- whole modules with 'load' --- --- 'setInteractiveDynFlags', 'getInteractiveDynFlags' work with the --- interactive @DynFlags@. --- --- 'setProgramDynFlags', 'getProgramDynFlags' work with the --- program @DynFlags@. --- --- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags' --- retrieves the program @DynFlags@ (for backwards compatibility). - - --- | Updates both the interactive and program DynFlags in a Session. --- This also reads the package database (unless it has already been --- read), and prepares the compilers knowledge about packages. It can --- be called again to load new packages: just add new package flags to --- (packageFlags dflags). --- --- Returns a list of new packages that may need to be linked in using --- the dynamic linker (see 'linkPackages') as a result of new package --- flags. If you are not doing linking or doing static linking, you --- can ignore the list of packages returned. --- -setSessionDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId] -setSessionDynFlags dflags = do - dflags' <- checkNewDynFlags dflags - dflags'' <- liftIO $ interpretPackageEnv dflags' - (dflags''', preload) <- liftIO $ initPackages dflags'' - modifySession $ \h -> h{ hsc_dflags = dflags''' - , hsc_IC = (hsc_IC h){ ic_dflags = dflags''' } } - invalidateModSummaryCache - return preload - --- | Sets the program 'DynFlags'. Note: this invalidates the internal --- cached module graph, causing more work to be done the next time --- 'load' is called. -setProgramDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId] -setProgramDynFlags dflags = setProgramDynFlags_ True dflags - --- | Set the action taken when the compiler produces a message. This --- can also be accomplished using 'setProgramDynFlags', but using --- 'setLogAction' avoids invalidating the cached module graph. -setLogAction :: GhcMonad m => LogAction -> m () -setLogAction action = do - dflags' <- getProgramDynFlags - void $ setProgramDynFlags_ False $ - dflags' { log_action = action } - -setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [InstalledUnitId] -setProgramDynFlags_ invalidate_needed dflags = do - dflags' <- checkNewDynFlags dflags - dflags_prev <- getProgramDynFlags - (dflags'', preload) <- - if (packageFlagsChanged dflags_prev dflags') - then liftIO $ initPackages dflags' - else return (dflags', []) - modifySession $ \h -> h{ hsc_dflags = dflags'' } - when invalidate_needed $ invalidateModSummaryCache - return preload - - --- When changing the DynFlags, we want the changes to apply to future --- loads, but without completely discarding the program. But the --- DynFlags are cached in each ModSummary in the hsc_mod_graph, so --- after a change to DynFlags, the changes would apply to new modules --- but not existing modules; this seems undesirable. --- --- Furthermore, the GHC API client might expect that changing --- log_action would affect future compilation messages, but for those --- modules we have cached ModSummaries for, we'll continue to use the --- old log_action. This is definitely wrong (#7478). --- --- Hence, we invalidate the ModSummary cache after changing the --- DynFlags. We do this by tweaking the date on each ModSummary, so --- that the next downsweep will think that all the files have changed --- and preprocess them again. This won't necessarily cause everything --- to be recompiled, because by the time we check whether we need to --- recompile a module, we'll have re-summarised the module and have a --- correct ModSummary. --- -invalidateModSummaryCache :: GhcMonad m => m () -invalidateModSummaryCache = - modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) } - where - inval ms = ms { ms_hs_date = addUTCTime (-1) (ms_hs_date ms) } - --- | Returns the program 'DynFlags'. -getProgramDynFlags :: GhcMonad m => m DynFlags -getProgramDynFlags = getSessionDynFlags - --- | Set the 'DynFlags' used to evaluate interactive expressions. --- Note: this cannot be used for changes to packages. Use --- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the --- 'pkgState' into the interactive @DynFlags@. -setInteractiveDynFlags :: GhcMonad m => DynFlags -> m () -setInteractiveDynFlags dflags = do - dflags' <- checkNewDynFlags dflags - dflags'' <- checkNewInteractiveDynFlags dflags' - modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags'' }} - --- | Get the 'DynFlags' used to evaluate interactive expressions. -getInteractiveDynFlags :: GhcMonad m => m DynFlags -getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h)) - - -parseDynamicFlags :: MonadIO m => - DynFlags -> [Located String] - -> m (DynFlags, [Located String], [Warn]) -parseDynamicFlags = parseDynamicFlagsCmdLine - --- | Checks the set of new DynFlags for possibly erroneous option --- combinations when invoking 'setSessionDynFlags' and friends, and if --- found, returns a fixed copy (if possible). -checkNewDynFlags :: MonadIO m => DynFlags -> m DynFlags -checkNewDynFlags dflags = do - -- See Note [DynFlags consistency] - let (dflags', warnings) = makeDynFlagsConsistent dflags - liftIO $ handleFlagWarnings dflags (map (Warn NoReason) warnings) - return dflags' - -checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags -checkNewInteractiveDynFlags dflags0 = do - -- We currently don't support use of StaticPointers in expressions entered on - -- the REPL. See #12356. - if xopt LangExt.StaticPointers dflags0 - then do liftIO $ printOrThrowWarnings dflags0 $ listToBag - [mkPlainWarnMsg dflags0 interactiveSrcSpan - $ text "StaticPointers is not supported in GHCi interactive expressions."] - return $ xopt_unset dflags0 LangExt.StaticPointers - else return dflags0 - - --- %************************************************************************ --- %* * --- Setting, getting, and modifying the targets --- %* * --- %************************************************************************ - --- ToDo: think about relative vs. absolute file paths. And what --- happens when the current directory changes. - --- | Sets the targets for this session. Each target may be a module name --- or a filename. The targets correspond to the set of root modules for --- the program\/library. Unloading the current program is achieved by --- setting the current set of targets to be empty, followed by 'load'. -setTargets :: GhcMonad m => [Target] -> m () -setTargets targets = modifySession (\h -> h{ hsc_targets = targets }) - --- | Returns the current set of targets -getTargets :: GhcMonad m => m [Target] -getTargets = withSession (return . hsc_targets) - --- | Add another target. -addTarget :: GhcMonad m => Target -> m () -addTarget target - = modifySession (\h -> h{ hsc_targets = target : hsc_targets h }) - --- | Remove a target -removeTarget :: GhcMonad m => TargetId -> m () -removeTarget target_id - = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) }) - where - filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ] - --- | Attempts to guess what Target a string refers to. This function --- implements the @--make@/GHCi command-line syntax for filenames: --- --- - if the string looks like a Haskell source filename, then interpret it --- as such --- --- - if adding a .hs or .lhs suffix yields the name of an existing file, --- then use that --- --- - otherwise interpret the string as a module name --- -guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target -guessTarget str (Just phase) - = return (Target (TargetFile str (Just phase)) True Nothing) -guessTarget str Nothing - | isHaskellSrcFilename file - = return (target (TargetFile file Nothing)) - | otherwise - = do exists <- liftIO $ doesFileExist hs_file - if exists - then return (target (TargetFile hs_file Nothing)) - else do - exists <- liftIO $ doesFileExist lhs_file - if exists - then return (target (TargetFile lhs_file Nothing)) - else do - if looksLikeModuleName file - then return (target (TargetModule (mkModuleName file))) - else do - dflags <- getDynFlags - liftIO $ throwGhcExceptionIO - (ProgramError (showSDoc dflags $ - text "target" <+> quotes (text file) <+> - text "is not a module name or a source file")) - where - (file,obj_allowed) - | '*':rest <- str = (rest, False) - | otherwise = (str, True) - - hs_file = file <.> "hs" - lhs_file = file <.> "lhs" - - target tid = Target tid obj_allowed Nothing - - --- | Inform GHC that the working directory has changed. GHC will flush --- its cache of module locations, since it may no longer be valid. --- --- Note: Before changing the working directory make sure all threads running --- in the same session have stopped. If you change the working directory, --- you should also unload the current program (set targets to empty, --- followed by load). -workingDirectoryChanged :: GhcMonad m => m () -workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches) - - --- %************************************************************************ --- %* * --- Running phases one at a time --- %* * --- %************************************************************************ - -class ParsedMod m where - modSummary :: m -> ModSummary - parsedSource :: m -> ParsedSource - -class ParsedMod m => TypecheckedMod m where - renamedSource :: m -> Maybe RenamedSource - typecheckedSource :: m -> TypecheckedSource - moduleInfo :: m -> ModuleInfo - tm_internals :: m -> (TcGblEnv, ModDetails) - -- ToDo: improvements that could be made here: - -- if the module succeeded renaming but not typechecking, - -- we can still get back the GlobalRdrEnv and exports, so - -- perhaps the ModuleInfo should be split up into separate - -- fields. - -class TypecheckedMod m => DesugaredMod m where - coreModule :: m -> ModGuts - --- | The result of successful parsing. -data ParsedModule = - ParsedModule { pm_mod_summary :: ModSummary - , pm_parsed_source :: ParsedSource - , pm_extra_src_files :: [FilePath] - , pm_annotations :: ApiAnns } - -- See Note [Api annotations] in ApiAnnotation.hs - -instance ParsedMod ParsedModule where - modSummary m = pm_mod_summary m - parsedSource m = pm_parsed_source m - --- | The result of successful typechecking. It also contains the parser --- result. -data TypecheckedModule = - TypecheckedModule { tm_parsed_module :: ParsedModule - , tm_renamed_source :: Maybe RenamedSource - , tm_typechecked_source :: TypecheckedSource - , tm_checked_module_info :: ModuleInfo - , tm_internals_ :: (TcGblEnv, ModDetails) - } - -instance ParsedMod TypecheckedModule where - modSummary m = modSummary (tm_parsed_module m) - parsedSource m = parsedSource (tm_parsed_module m) - -instance TypecheckedMod TypecheckedModule where - renamedSource m = tm_renamed_source m - typecheckedSource m = tm_typechecked_source m - moduleInfo m = tm_checked_module_info m - tm_internals m = tm_internals_ m - --- | The result of successful desugaring (i.e., translation to core). Also --- contains all the information of a typechecked module. -data DesugaredModule = - DesugaredModule { dm_typechecked_module :: TypecheckedModule - , dm_core_module :: ModGuts - } - -instance ParsedMod DesugaredModule where - modSummary m = modSummary (dm_typechecked_module m) - parsedSource m = parsedSource (dm_typechecked_module m) - -instance TypecheckedMod DesugaredModule where - renamedSource m = renamedSource (dm_typechecked_module m) - typecheckedSource m = typecheckedSource (dm_typechecked_module m) - moduleInfo m = moduleInfo (dm_typechecked_module m) - tm_internals m = tm_internals_ (dm_typechecked_module m) - -instance DesugaredMod DesugaredModule where - coreModule m = dm_core_module m - -type ParsedSource = Located HsModule -type RenamedSource = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], - Maybe LHsDocString) -type TypecheckedSource = LHsBinds GhcTc - --- NOTE: --- - things that aren't in the output of the typechecker right now: --- - the export list --- - the imports --- - type signatures --- - type/data/newtype declarations --- - class declarations --- - instances --- - extra things in the typechecker's output: --- - default methods are turned into top-level decls. --- - dictionary bindings - --- | Return the 'ModSummary' of a module with the given name. --- --- The module must be part of the module graph (see 'hsc_mod_graph' and --- 'ModuleGraph'). If this is not the case, this function will throw a --- 'GhcApiError'. --- --- This function ignores boot modules and requires that there is only one --- non-boot module with the given name. -getModSummary :: GhcMonad m => ModuleName -> m ModSummary -getModSummary mod = do - mg <- liftM hsc_mod_graph getSession - let mods_by_name = [ ms | ms <- mgModSummaries mg - , ms_mod_name ms == mod - , not (isBootSummary ms) ] - case mods_by_name of - [] -> do dflags <- getDynFlags - liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph") - [ms] -> return ms - multiple -> do dflags <- getDynFlags - liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple) - --- | Parse a module. --- --- Throws a 'SourceError' on parse error. -parseModule :: GhcMonad m => ModSummary -> m ParsedModule -parseModule ms = do - hsc_env <- getSession - let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } - hpm <- liftIO $ hscParse hsc_env_tmp ms - return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm) - (hpm_annotations hpm)) - -- See Note [Api annotations] in ApiAnnotation.hs - --- | Typecheck and rename a parsed module. --- --- Throws a 'SourceError' if either fails. -typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule -typecheckModule pmod = do - let ms = modSummary pmod - hsc_env <- getSession - let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } - (tc_gbl_env, rn_info) - <- liftIO $ hscTypecheckRename hsc_env_tmp ms $ - HsParsedModule { hpm_module = parsedSource pmod, - hpm_src_files = pm_extra_src_files pmod, - hpm_annotations = pm_annotations pmod } - details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env - safe <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env - - return $ - TypecheckedModule { - tm_internals_ = (tc_gbl_env, details), - tm_parsed_module = pmod, - tm_renamed_source = rn_info, - tm_typechecked_source = tcg_binds tc_gbl_env, - tm_checked_module_info = - ModuleInfo { - minf_type_env = md_types details, - minf_exports = md_exports details, - minf_rdr_env = Just (tcg_rdr_env tc_gbl_env), - minf_instances = fixSafeInstances safe $ md_insts details, - minf_iface = Nothing, - minf_safe = safe, - minf_modBreaks = emptyModBreaks - }} - --- | Desugar a typechecked module. -desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule -desugarModule tcm = do - let ms = modSummary tcm - let (tcg, _) = tm_internals tcm - hsc_env <- getSession - let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } - guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg - return $ - DesugaredModule { - dm_typechecked_module = tcm, - dm_core_module = guts - } - --- | Load a module. Input doesn't need to be desugared. --- --- A module must be loaded before dependent modules can be typechecked. This --- always includes generating a 'ModIface' and, depending on the --- 'DynFlags.hscTarget', may also include code generation. --- --- This function will always cause recompilation and will always overwrite --- previous compilation results (potentially files on disk). --- -loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod -loadModule tcm = do - let ms = modSummary tcm - let mod = ms_mod_name ms - let loc = ms_location ms - let (tcg, _details) = tm_internals tcm - - mb_linkable <- case ms_obj_date ms of - Just t | t > ms_hs_date ms -> do - l <- liftIO $ findObjectLinkable (ms_mod ms) - (ml_obj_file loc) t - return (Just l) - _otherwise -> return Nothing - - let source_modified | isNothing mb_linkable = SourceModified - | otherwise = SourceUnmodified - -- we can't determine stability here - - -- compile doesn't change the session - hsc_env <- getSession - mod_info <- liftIO $ compileOne' (Just tcg) Nothing - hsc_env ms 1 1 Nothing mb_linkable - source_modified - - modifySession $ \e -> e{ hsc_HPT = addToHpt (hsc_HPT e) mod mod_info } - return tcm - - --- %************************************************************************ --- %* * --- Dealing with Core --- %* * --- %************************************************************************ - --- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for --- the 'GHC.compileToCoreModule' interface. -data CoreModule - = CoreModule { - -- | Module name - cm_module :: !Module, - -- | Type environment for types declared in this module - cm_types :: !TypeEnv, - -- | Declarations - cm_binds :: CoreProgram, - -- | Safe Haskell mode - cm_safe :: SafeHaskellMode - } - -instance Outputable CoreModule where - ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb, - cm_safe = sf}) - = text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te - $$ vcat (map ppr cb) - --- | This is the way to get access to the Core bindings corresponding --- to a module. 'compileToCore' parses, typechecks, and --- desugars the module, then returns the resulting Core module (consisting of --- the module name, type declarations, and function declarations) if --- successful. -compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule -compileToCoreModule = compileCore False - --- | Like compileToCoreModule, but invokes the simplifier, so --- as to return simplified and tidied Core. -compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule -compileToCoreSimplified = compileCore True - -compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule -compileCore simplify fn = do - -- First, set the target to the desired filename - target <- guessTarget fn Nothing - addTarget target - _ <- load LoadAllTargets - -- Then find dependencies - modGraph <- depanal [] True - case find ((== fn) . msHsFilePath) (mgModSummaries modGraph) of - Just modSummary -> do - -- Now we have the module name; - -- parse, typecheck and desugar the module - (tcg, mod_guts) <- -- TODO: space leaky: call hsc* directly? - do tm <- typecheckModule =<< parseModule modSummary - let tcg = fst (tm_internals tm) - (,) tcg . coreModule <$> desugarModule tm - liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $ - if simplify - then do - -- If simplify is true: simplify (hscSimplify), then tidy - -- (tidyProgram). - hsc_env <- getSession - simpl_guts <- liftIO $ do - plugins <- readIORef (tcg_th_coreplugins tcg) - hscSimplify hsc_env plugins mod_guts - tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts - return $ Left tidy_guts - else - return $ Right mod_guts - - Nothing -> panic "compileToCoreModule: target FilePath not found in\ - module dependency graph" - where -- two versions, based on whether we simplify (thus run tidyProgram, - -- which returns a (CgGuts, ModDetails) pair, or not (in which case - -- we just have a ModGuts. - gutsToCoreModule :: SafeHaskellMode - -> Either (CgGuts, ModDetails) ModGuts - -> CoreModule - gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule { - cm_module = cg_module cg, - cm_types = md_types md, - cm_binds = cg_binds cg, - cm_safe = safe_mode - } - gutsToCoreModule safe_mode (Right mg) = CoreModule { - cm_module = mg_module mg, - cm_types = typeEnvFromEntities (bindersOfBinds (mg_binds mg)) - (mg_tcs mg) - (mg_fam_insts mg), - cm_binds = mg_binds mg, - cm_safe = safe_mode - } - --- %************************************************************************ --- %* * --- Inspecting the session --- %* * --- %************************************************************************ - --- | Get the module dependency graph. -getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary -getModuleGraph = liftM hsc_mod_graph getSession - --- | Return @True@ <==> module is loaded. -isLoaded :: GhcMonad m => ModuleName -> m Bool -isLoaded m = withSession $ \hsc_env -> - return $! isJust (lookupHpt (hsc_HPT hsc_env) m) - --- | Return the bindings for the current interactive session. -getBindings :: GhcMonad m => m [TyThing] -getBindings = withSession $ \hsc_env -> - return $ icInScopeTTs $ hsc_IC hsc_env - --- | Return the instances for the current interactive session. -getInsts :: GhcMonad m => m ([ClsInst], [FamInst]) -getInsts = withSession $ \hsc_env -> - return $ ic_instances (hsc_IC hsc_env) - -getPrintUnqual :: GhcMonad m => m PrintUnqualified -getPrintUnqual = withSession $ \hsc_env -> - return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env)) - --- | Container for information about a 'Module'. -data ModuleInfo = ModuleInfo { - minf_type_env :: TypeEnv, - minf_exports :: [AvailInfo], - minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod - minf_instances :: [ClsInst], - minf_iface :: Maybe ModIface, - minf_safe :: SafeHaskellMode, - minf_modBreaks :: ModBreaks - } - -- We don't want HomeModInfo here, because a ModuleInfo applies - -- to package modules too. - --- | Request information about a loaded 'Module' -getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X -getModuleInfo mdl = withSession $ \hsc_env -> do - let mg = hsc_mod_graph hsc_env - if mgElemModule mg mdl - then liftIO $ getHomeModuleInfo hsc_env mdl - else do - {- if isHomeModule (hsc_dflags hsc_env) mdl - then return Nothing - else -} liftIO $ getPackageModuleInfo hsc_env mdl - -- ToDo: we don't understand what the following comment means. - -- (SDM, 19/7/2011) - -- getPackageModuleInfo will attempt to find the interface, so - -- we don't want to call it for a home module, just in case there - -- was a problem loading the module and the interface doesn't - -- exist... hence the isHomeModule test here. (ToDo: reinstate) - -getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) -getPackageModuleInfo hsc_env mdl - = do eps <- hscEPS hsc_env - iface <- hscGetModuleInterface hsc_env mdl - let - avails = mi_exports iface - pte = eps_PTE eps - tys = [ ty | name <- concatMap availNames avails, - Just ty <- [lookupTypeEnv pte name] ] - -- - return (Just (ModuleInfo { - minf_type_env = mkTypeEnv tys, - minf_exports = avails, - minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, - minf_instances = error "getModuleInfo: instances for package module unimplemented", - minf_iface = Just iface, - minf_safe = getSafeMode $ mi_trust iface, - minf_modBreaks = emptyModBreaks - })) - -getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) -getHomeModuleInfo hsc_env mdl = - case lookupHpt (hsc_HPT hsc_env) (moduleName mdl) of - Nothing -> return Nothing - Just hmi -> do - let details = hm_details hmi - iface = hm_iface hmi - return (Just (ModuleInfo { - minf_type_env = md_types details, - minf_exports = md_exports details, - minf_rdr_env = mi_globals $! hm_iface hmi, - minf_instances = md_insts details, - minf_iface = Just iface, - minf_safe = getSafeMode $ mi_trust iface - ,minf_modBreaks = getModBreaks hmi - })) - --- | The list of top-level entities defined in a module -modInfoTyThings :: ModuleInfo -> [TyThing] -modInfoTyThings minf = typeEnvElts (minf_type_env minf) - -modInfoTopLevelScope :: ModuleInfo -> Maybe [Name] -modInfoTopLevelScope minf - = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf) - -modInfoExports :: ModuleInfo -> [Name] -modInfoExports minf = concatMap availNames $! minf_exports minf - -modInfoExportsWithSelectors :: ModuleInfo -> [Name] -modInfoExportsWithSelectors minf = concatMap availNamesWithSelectors $! minf_exports minf - --- | Returns the instances defined by the specified module. --- Warning: currently unimplemented for package modules. -modInfoInstances :: ModuleInfo -> [ClsInst] -modInfoInstances = minf_instances - -modInfoIsExportedName :: ModuleInfo -> Name -> Bool -modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf)) - -mkPrintUnqualifiedForModule :: GhcMonad m => - ModuleInfo - -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X -mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do - return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf)) - -modInfoLookupName :: GhcMonad m => - ModuleInfo -> Name - -> m (Maybe TyThing) -- XXX: returns a Maybe X -modInfoLookupName minf name = withSession $ \hsc_env -> do - case lookupTypeEnv (minf_type_env minf) name of - Just tyThing -> return (Just tyThing) - Nothing -> do - eps <- liftIO $ readIORef (hsc_EPS hsc_env) - return $! lookupType (hsc_dflags hsc_env) - (hsc_HPT hsc_env) (eps_PTE eps) name - -modInfoIface :: ModuleInfo -> Maybe ModIface -modInfoIface = minf_iface - -modInfoRdrEnv :: ModuleInfo -> Maybe GlobalRdrEnv -modInfoRdrEnv = minf_rdr_env - --- | Retrieve module safe haskell mode -modInfoSafe :: ModuleInfo -> SafeHaskellMode -modInfoSafe = minf_safe - -modInfoModBreaks :: ModuleInfo -> ModBreaks -modInfoModBreaks = minf_modBreaks - -isDictonaryId :: Id -> Bool -isDictonaryId id - = case tcSplitSigmaTy (idType id) of { - (_tvs, _theta, tau) -> isDictTy tau } - --- | Looks up a global name: that is, any top-level name in any --- visible module. Unlike 'lookupName', lookupGlobalName does not use --- the interactive context, and therefore does not require a preceding --- 'setContext'. -lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing) -lookupGlobalName name = withSession $ \hsc_env -> do - liftIO $ lookupTypeHscEnv hsc_env name - -findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a] -findGlobalAnns deserialize target = withSession $ \hsc_env -> do - ann_env <- liftIO $ prepareAnnotations hsc_env Nothing - return (findAnns deserialize ann_env target) - --- | get the GlobalRdrEnv for a session -getGRE :: GhcMonad m => m GlobalRdrEnv -getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env) - --- | Retrieve all type and family instances in the environment, indexed --- by 'Name'. Each name's lists will contain every instance in which that name --- is mentioned in the instance head. -getNameToInstancesIndex :: GhcMonad m - => [Module] -- ^ visible modules. An orphan instance will be returned - -- if it is visible from at least one module in the list. - -> Maybe [Module] -- ^ modules to load. If this is not specified, we load - -- modules for everything that is in scope unqualified. - -> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst]))) -getNameToInstancesIndex visible_mods mods_to_load = do - hsc_env <- getSession - liftIO $ runTcInteractive hsc_env $ - do { case mods_to_load of - Nothing -> loadUnqualIfaces hsc_env (hsc_IC hsc_env) - Just mods -> - let doc = text "Need interface for reporting instances in scope" - in initIfaceTcRn $ mapM_ (loadSysInterface doc) mods - - ; InstEnvs {ie_global, ie_local} <- tcGetInstEnvs - ; let visible_mods' = mkModuleSet visible_mods - ; (pkg_fie, home_fie) <- tcGetFamInstEnvs - -- We use Data.Sequence.Seq because we are creating left associated - -- mappends. - -- cls_index and fam_index below are adapted from TcRnDriver.lookupInsts - ; let cls_index = Map.fromListWith mappend - [ (n, Seq.singleton ispec) - | ispec <- instEnvElts ie_local ++ instEnvElts ie_global - , instIsVisible visible_mods' ispec - , n <- nameSetElemsStable $ orphNamesOfClsInst ispec - ] - ; let fam_index = Map.fromListWith mappend - [ (n, Seq.singleton fispec) - | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie - , n <- nameSetElemsStable $ orphNamesOfFamInst fispec - ] - ; return $ mkNameEnv $ - [ (nm, (toList clss, toList fams)) - | (nm, (clss, fams)) <- Map.toList $ Map.unionWith mappend - (fmap (,Seq.empty) cls_index) - (fmap (Seq.empty,) fam_index) - ] } - --- ----------------------------------------------------------------------------- - -{- ToDo: Move the primary logic here to compiler/main/Packages.hs --- | Return all /external/ modules available in the package database. --- Modules from the current session (i.e., from the 'HomePackageTable') are --- not included. This includes module names which are reexported by packages. -packageDbModules :: GhcMonad m => - Bool -- ^ Only consider exposed packages. - -> m [Module] -packageDbModules only_exposed = do - dflags <- getSessionDynFlags - let pkgs = eltsUFM (unitInfoMap (pkgState dflags)) - return $ - [ mkModule pid modname - | p <- pkgs - , not only_exposed || exposed p - , let pid = packageConfigId p - , modname <- exposedModules p - ++ map exportName (reexportedModules p) ] - -} - --- ----------------------------------------------------------------------------- --- Misc exported utils - -dataConType :: DataCon -> Type -dataConType dc = idType (dataConWrapId dc) - --- | print a 'NamedThing', adding parentheses if the name is an operator. -pprParenSymName :: NamedThing a => a -> SDoc -pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a)) - --- ---------------------------------------------------------------------------- - - --- ToDo: --- - Data and Typeable instances for HsSyn. - --- ToDo: check for small transformations that happen to the syntax in --- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral) - --- ToDo: maybe use TH syntax instead of Iface syntax? There's already a way --- to get from TyCons, Ids etc. to TH syntax (reify). - --- :browse will use either lm_toplev or inspect lm_interface, depending --- on whether the module is interpreted or not. - - --- Extract the filename, stringbuffer content and dynflags associed to a module --- --- XXX: Explain pre-conditions -getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags) -getModuleSourceAndFlags mod = do - m <- getModSummary (moduleName mod) - case ml_hs_file $ ms_location m of - Nothing -> do dflags <- getDynFlags - liftIO $ throwIO $ mkApiErr dflags (text "No source available for module " <+> ppr mod) - Just sourceFile -> do - source <- liftIO $ hGetStringBuffer sourceFile - return (sourceFile, source, ms_hspp_opts m) - - --- | Return module source as token stream, including comments. --- --- The module must be in the module graph and its source must be available. --- Throws a 'HscTypes.SourceError' on parse error. -getTokenStream :: GhcMonad m => Module -> m [Located Token] -getTokenStream mod = do - (sourceFile, source, flags) <- getModuleSourceAndFlags mod - let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 - case lexTokenStream source startLoc flags of - POk _ ts -> return ts - PFailed pst -> - do dflags <- getDynFlags - throwErrors (getErrorMessages pst dflags) - --- | Give even more information on the source than 'getTokenStream' --- This function allows reconstructing the source completely with --- 'showRichTokenStream'. -getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)] -getRichTokenStream mod = do - (sourceFile, source, flags) <- getModuleSourceAndFlags mod - let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 - case lexTokenStream source startLoc flags of - POk _ ts -> return $ addSourceToTokens startLoc source ts - PFailed pst -> - do dflags <- getDynFlags - throwErrors (getErrorMessages pst dflags) - --- | Given a source location and a StringBuffer corresponding to this --- location, return a rich token stream with the source associated to the --- tokens. -addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token] - -> [(Located Token, String)] -addSourceToTokens _ _ [] = [] -addSourceToTokens loc buf (t@(L span _) : ts) - = case span of - UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts - RealSrcSpan s -> (t,str) : addSourceToTokens newLoc newBuf ts - where - (newLoc, newBuf, str) = go "" loc buf - start = realSrcSpanStart s - end = realSrcSpanEnd s - go acc loc buf | loc < start = go acc nLoc nBuf - | start <= loc && loc < end = go (ch:acc) nLoc nBuf - | otherwise = (loc, buf, reverse acc) - where (ch, nBuf) = nextChar buf - nLoc = advanceSrcLoc loc ch - - --- | Take a rich token stream such as produced from 'getRichTokenStream' and --- return source code almost identical to the original code (except for --- insignificant whitespace.) -showRichTokenStream :: [(Located Token, String)] -> String -showRichTokenStream ts = go startLoc ts "" - where sourceFile = getFile $ map (getLoc . fst) ts - getFile [] = panic "showRichTokenStream: No source file found" - getFile (UnhelpfulSpan _ : xs) = getFile xs - getFile (RealSrcSpan s : _) = srcSpanFile s - startLoc = mkRealSrcLoc sourceFile 1 1 - go _ [] = id - go loc ((L span _, str):ts) - = case span of - UnhelpfulSpan _ -> go loc ts - RealSrcSpan s - | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++) - . (str ++) - . go tokEnd ts - | otherwise -> ((replicate (tokLine - locLine) '\n') ++) - . ((replicate (tokCol - 1) ' ') ++) - . (str ++) - . go tokEnd ts - where (locLine, locCol) = (srcLocLine loc, srcLocCol loc) - (tokLine, tokCol) = (srcSpanStartLine s, srcSpanStartCol s) - tokEnd = realSrcSpanEnd s - --- ----------------------------------------------------------------------------- --- Interactive evaluation - --- | Takes a 'ModuleName' and possibly a 'UnitId', and consults the --- filesystem and package database to find the corresponding 'Module', --- using the algorithm that is used for an @import@ declaration. -findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module -findModule mod_name maybe_pkg = withSession $ \hsc_env -> do - let - dflags = hsc_dflags hsc_env - this_pkg = thisPackage dflags - -- - case maybe_pkg of - Just pkg | fsToUnitId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do - res <- findImportedModule hsc_env mod_name maybe_pkg - case res of - Found _ m -> return m - err -> throwOneError $ noModError dflags noSrcSpan mod_name err - _otherwise -> do - home <- lookupLoadedHomeModule mod_name - case home of - Just m -> return m - Nothing -> liftIO $ do - res <- findImportedModule hsc_env mod_name maybe_pkg - case res of - Found loc m | moduleUnitId m /= this_pkg -> return m - | otherwise -> modNotLoadedError dflags m loc - err -> throwOneError $ noModError dflags noSrcSpan mod_name err - -modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a -modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $ - text "module is not loaded:" <+> - quotes (ppr (moduleName m)) <+> - parens (text (expectJust "modNotLoadedError" (ml_hs_file loc))) - --- | Like 'findModule', but differs slightly when the module refers to --- a source file, and the file has not been loaded via 'load'. In --- this case, 'findModule' will throw an error (module not loaded), --- but 'lookupModule' will check to see whether the module can also be --- found in a package, and if so, that package 'Module' will be --- returned. If not, the usual module-not-found error will be thrown. --- -lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module -lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg) -lookupModule mod_name Nothing = withSession $ \hsc_env -> do - home <- lookupLoadedHomeModule mod_name - case home of - Just m -> return m - Nothing -> liftIO $ do - res <- findExposedPackageModule hsc_env mod_name Nothing - case res of - Found _ m -> return m - err -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err - -lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module) -lookupLoadedHomeModule mod_name = withSession $ \hsc_env -> - case lookupHpt (hsc_HPT hsc_env) mod_name of - Just mod_info -> return (Just (mi_module (hm_iface mod_info))) - _not_a_home_module -> return Nothing - --- | Check that a module is safe to import (according to Safe Haskell). --- --- We return True to indicate the import is safe and False otherwise --- although in the False case an error may be thrown first. -isModuleTrusted :: GhcMonad m => Module -> m Bool -isModuleTrusted m = withSession $ \hsc_env -> - liftIO $ hscCheckSafe hsc_env m noSrcSpan - --- | Return if a module is trusted and the pkgs it depends on to be trusted. -moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set InstalledUnitId) -moduleTrustReqs m = withSession $ \hsc_env -> - liftIO $ hscGetSafe hsc_env m noSrcSpan - --- | Set the monad GHCi lifts user statements into. --- --- Checks that a type (in string form) is an instance of the --- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is, --- throws an error otherwise. -setGHCiMonad :: GhcMonad m => String -> m () -setGHCiMonad name = withSession $ \hsc_env -> do - ty <- liftIO $ hscIsGHCiMonad hsc_env name - modifySession $ \s -> - let ic = (hsc_IC s) { ic_monad = ty } - in s { hsc_IC = ic } - --- | Get the monad GHCi lifts user statements into. -getGHCiMonad :: GhcMonad m => m Name -getGHCiMonad = fmap (ic_monad . hsc_IC) getSession - -getHistorySpan :: GhcMonad m => History -> m SrcSpan -getHistorySpan h = withSession $ \hsc_env -> - return $ GHC.Runtime.Eval.getHistorySpan hsc_env h - -obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term -obtainTermFromVal bound force ty a = withSession $ \hsc_env -> - liftIO $ GHC.Runtime.Eval.obtainTermFromVal hsc_env bound force ty a - -obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term -obtainTermFromId bound force id = withSession $ \hsc_env -> - liftIO $ GHC.Runtime.Eval.obtainTermFromId hsc_env bound force id - - --- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any --- entity known to GHC, including 'Name's defined using 'runStmt'. -lookupName :: GhcMonad m => Name -> m (Maybe TyThing) -lookupName name = - withSession $ \hsc_env -> - liftIO $ hscTcRcLookupName hsc_env name - --- ----------------------------------------------------------------------------- --- Pure API - --- | A pure interface to the module parser. --- -parser :: String -- ^ Haskell module source text (full Unicode is supported) - -> DynFlags -- ^ the flags - -> FilePath -- ^ the filename (for source locations) - -> (WarningMessages, Either ErrorMessages (Located HsModule)) - -parser str dflags filename = - let - loc = mkRealSrcLoc (mkFastString filename) 1 1 - buf = stringToStringBuffer str - in - case unP Parser.parseModule (mkPState dflags buf loc) of - - PFailed pst -> - let (warns,errs) = getMessages pst dflags in - (warns, Left errs) - - POk pst rdr_module -> - let (warns,_) = getMessages pst dflags in - (warns, Right rdr_module) - --- ----------------------------------------------------------------------------- --- | Find the package environment (if one exists) --- --- We interpret the package environment as a set of package flags; to be --- specific, if we find a package environment file like --- --- > clear-package-db --- > global-package-db --- > package-db blah/package.conf.d --- > package-id id1 --- > package-id id2 --- --- we interpret this as --- --- > [ -hide-all-packages --- > , -clear-package-db --- > , -global-package-db --- > , -package-db blah/package.conf.d --- > , -package-id id1 --- > , -package-id id2 --- > ] --- --- There's also an older syntax alias for package-id, which is just an --- unadorned package id --- --- > id1 --- > id2 --- -interpretPackageEnv :: DynFlags -> IO DynFlags -interpretPackageEnv dflags = do - mPkgEnv <- runMaybeT $ msum $ [ - getCmdLineArg >>= \env -> msum [ - probeNullEnv env - , probeEnvFile env - , probeEnvName env - , cmdLineError env - ] - , getEnvVar >>= \env -> msum [ - probeNullEnv env - , probeEnvFile env - , probeEnvName env - , envError env - ] - , notIfHideAllPackages >> msum [ - findLocalEnvFile >>= probeEnvFile - , probeEnvName defaultEnvName - ] - ] - case mPkgEnv of - Nothing -> - -- No environment found. Leave DynFlags unchanged. - return dflags - Just "-" -> do - -- Explicitly disabled environment file. Leave DynFlags unchanged. - return dflags - Just envfile -> do - content <- readFile envfile - compilationProgressMsg dflags ("Loaded package environment from " ++ envfile) - let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags - - return dflags' - where - -- Loading environments (by name or by location) - - namedEnvPath :: String -> MaybeT IO FilePath - namedEnvPath name = do - appdir <- versionedAppDir dflags - return $ appdir </> "environments" </> name - - probeEnvName :: String -> MaybeT IO FilePath - probeEnvName name = probeEnvFile =<< namedEnvPath name - - probeEnvFile :: FilePath -> MaybeT IO FilePath - probeEnvFile path = do - guard =<< liftMaybeT (doesFileExist path) - return path - - probeNullEnv :: FilePath -> MaybeT IO FilePath - probeNullEnv "-" = return "-" - probeNullEnv _ = mzero - - -- Various ways to define which environment to use - - getCmdLineArg :: MaybeT IO String - getCmdLineArg = MaybeT $ return $ packageEnv dflags - - getEnvVar :: MaybeT IO String - getEnvVar = do - mvar <- liftMaybeT $ try $ getEnv "GHC_ENVIRONMENT" - case mvar of - Right var -> return var - Left err -> if isDoesNotExistError err then mzero - else liftMaybeT $ throwIO err - - notIfHideAllPackages :: MaybeT IO () - notIfHideAllPackages = - guard (not (gopt Opt_HideAllPackages dflags)) - - defaultEnvName :: String - defaultEnvName = "default" - - -- e.g. .ghc.environment.x86_64-linux-7.6.3 - localEnvFileName :: FilePath - localEnvFileName = ".ghc.environment" <.> versionedFilePath dflags - - -- Search for an env file, starting in the current dir and looking upwards. - -- Fail if we get to the users home dir or the filesystem root. That is, - -- we don't look for an env file in the user's home dir. The user-wide - -- env lives in ghc's versionedAppDir/environments/default - findLocalEnvFile :: MaybeT IO FilePath - findLocalEnvFile = do - curdir <- liftMaybeT getCurrentDirectory - homedir <- tryMaybeT getHomeDirectory - let probe dir | isDrive dir || dir == homedir - = mzero - probe dir = do - let file = dir </> localEnvFileName - exists <- liftMaybeT (doesFileExist file) - if exists - then return file - else probe (takeDirectory dir) - probe curdir - - -- Error reporting - - cmdLineError :: String -> MaybeT IO a - cmdLineError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ - "Package environment " ++ show env ++ " not found" - - envError :: String -> MaybeT IO a - envError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ - "Package environment " - ++ show env - ++ " (specified in GHC_ENVIRONMENT) not found" |