depanal,
load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
workingDirectoryChanged,
- checkModule, CheckedModule(..),
+ checkModule, checkAndLoadModule, CheckedModule(..),
TypecheckedSource, ParsedSource, RenamedSource,
- compileToCore,
+ compileToCore, compileToCoreModule, compileToCoreSimplified,
+ compileCoreToObj,
-- * Parsing Haddock comments
parseHaddockComment,
setContext, getContext,
getNamesInScope,
getRdrNamesInScope,
+ getGRE,
moduleIsInterpreted,
getInfo,
exprType,
InteractiveEval.forward,
showModule,
isModuleInterpreted,
- compileExpr, HValue, dynCompileExpr,
+ InteractiveEval.compileExpr, HValue, dynCompileExpr,
lookupName,
GHC.obtainTerm, GHC.obtainTerm1, GHC.obtainTermB, reconstructType,
modInfoModBreaks,
#endif
import TcIface
+import TcRnTypes hiding (LIE)
import TcRnMonad ( initIfaceCheck )
import Packages
import NameSet
import RdrName
-import HsSyn
+import qualified HsSyn -- hack as we want to reexport the whole module
+import HsSyn hiding ((<.>))
import Type hiding (typeKind)
import TcType hiding (typeKind)
import Id
import DataCon
import Name hiding ( varName )
import OccName ( parenSymOcc )
-import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
+import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr,
+ emptyInstEnv )
+import FamInstEnv ( emptyFamInstEnv )
import SrcLoc
import CoreSyn
+import TidyPgm
import DriverPipeline
import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase )
-import HeaderInfo ( getImports, getOptions )
+import HeaderInfo
import Finder
-import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) )
+import HscMain
import HscTypes
import DynFlags
import StaticFlags
import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
cleanTempDirs )
import Module
-import UniqFM
+import LazyUniqFM
import UniqSet
import Unique
-import PackageConfig
import FiniteMap
import Panic
import Digraph
import Bag ( unitBag, listToBag )
-import ErrUtils ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg,
- mkPlainErrMsg, printBagOfErrors, printBagOfWarnings,
- WarnMsg )
-import qualified ErrUtils
+import ErrUtils
import Util
import StringBuffer ( StringBuffer, hGetStringBuffer )
import Outputable
import Maybes ( expectJust, mapCatMaybes )
import HaddockParse
import HaddockLex ( tokenise )
+import FastString
import Control.Concurrent
-import System.Directory ( getModificationTime, doesFileExist )
+import System.Directory ( getModificationTime, doesFileExist,
+ getCurrentDirectory )
import Data.Maybe
import Data.List
import qualified Data.List as List
import Control.Monad
import System.Exit ( exitWith, ExitCode(..) )
-import System.Time ( ClockTime )
+import System.Time ( ClockTime, getClockTime )
import Control.Exception as Exception hiding (handle)
import Data.IORef
+import System.FilePath
import System.IO
import System.IO.Error ( try, isDoesNotExistError )
import Prelude hiding (init)
-- | Starts a new session. A session consists of a set of loaded
-- modules, a set of options (DynFlags), and an interactive context.
+-- ToDo: explain argument [[mb_top_dir]]
newSession :: Maybe FilePath -> IO Session
newSession mb_top_dir = do
-- catch ^C
installSignalHandlers
initStaticOpts
- dflags0 <- initSysTools mb_top_dir defaultDynFlags
- dflags <- initDynFlags dflags0
+ dflags0 <- initDynFlags defaultDynFlags
+ dflags <- initSysTools mb_top_dir dflags0
env <- newHscEnv dflags
ref <- newIORef env
return (Session ref)
let isMain = (== mainModIs dflags) . ms_mod
[ms] <- return (filter isMain mod_graph)
ml_hs_file (ms_location ms)
- guessedName = fmap basenameOf mainModuleSrcPath
+ guessedName = fmap dropExtension mainModuleSrcPath
in
case outputFile dflags of
Just _ -> env
else do
return (Target (TargetModule (mkModuleName file)) Nothing)
where
- hs_file = file `joinFileExt` "hs"
- lhs_file = file `joinFileExt` "lhs"
+ hs_file = file <.> "hs"
+ lhs_file = file <.> "lhs"
-- -----------------------------------------------------------------------------
-- Extending the program scope
-- Parsing Haddock comments
parseHaddockComment :: String -> Either String (HsDoc RdrName)
-parseHaddockComment string = parseHaddockParagraphs (tokenise string)
+parseHaddockComment string =
+ case parseHaddockParagraphs (tokenise string) of
+ MyLeft x -> Left x
+ MyRight x -> Right x
-- -----------------------------------------------------------------------------
-- Loading the program
renamedSource :: Maybe RenamedSource,
typecheckedSource :: Maybe TypecheckedSource,
checkedModuleInfo :: Maybe ModuleInfo,
- coreBinds :: Maybe [CoreBind]
+ coreModule :: Maybe ModGuts
}
-- ToDo: improvements that could be made here:
-- if the module succeeded renaming but not typechecking,
-- If compileToCore is true, it also desugars the module and returns the
-- resulting Core bindings as a component of the CheckedModule.
checkModule :: Session -> ModuleName -> Bool -> IO (Maybe CheckedModule)
-checkModule (Session ref) mod compileToCore = do
- -- parse & typecheck the module
+checkModule (Session ref) mod compile_to_core
+ = do
hsc_env <- readIORef ref
let mg = hsc_mod_graph hsc_env
case [ ms | ms <- mg, ms_mod_name ms == mod ] of
[] -> return Nothing
- (ms:_) -> do
- mbChecked <- hscFileCheck
- hsc_env{hsc_dflags=ms_hspp_opts ms}
- ms compileToCore
- case mbChecked of
+ (ms:_) -> checkModule_ ref ms compile_to_core False
+
+-- | parses and typechecks a module, optionally generates Core, and also
+-- loads the module into the 'Session' so that modules which depend on
+-- this one may subsequently be typechecked using 'checkModule' or
+-- 'checkAndLoadModule'. If you need to check more than one module,
+-- you probably want to use 'checkAndLoadModule'. Constructing the
+-- interface takes a little work, so it might be slightly slower than
+-- 'checkModule'.
+checkAndLoadModule :: Session -> ModSummary -> Bool -> IO (Maybe CheckedModule)
+checkAndLoadModule (Session ref) ms compile_to_core
+ = checkModule_ ref ms compile_to_core True
+
+checkModule_ :: IORef HscEnv -> ModSummary -> Bool -> Bool
+ -> IO (Maybe CheckedModule)
+checkModule_ ref ms compile_to_core load
+ = do
+ let mod = ms_mod_name ms
+ hsc_env0 <- readIORef ref
+ let hsc_env = hsc_env0{hsc_dflags=ms_hspp_opts ms}
+ mb_parsed <- parseFile hsc_env ms
+ case mb_parsed of
Nothing -> return Nothing
- Just (HscChecked parsed renamed Nothing _) ->
- return (Just (CheckedModule {
- parsedSource = parsed,
- renamedSource = renamed,
- typecheckedSource = Nothing,
- checkedModuleInfo = Nothing,
- coreBinds = Nothing }))
- Just (HscChecked parsed renamed
- (Just (tc_binds, rdr_env, details))
- maybeCoreBinds) -> do
+ Just rdr_module -> do
+ mb_typechecked <- typecheckRenameModule hsc_env ms rdr_module
+ case mb_typechecked of
+ Nothing -> return (Just CheckedModule {
+ parsedSource = rdr_module,
+ renamedSource = Nothing,
+ typecheckedSource = Nothing,
+ checkedModuleInfo = Nothing,
+ coreModule = Nothing })
+ Just (tcg, rn_info) -> do
+ details <- makeSimpleDetails hsc_env tcg
+
+ let tc_binds = tcg_binds tcg
+ let rdr_env = tcg_rdr_env tcg
let minf = ModuleInfo {
minf_type_env = md_types details,
minf_exports = availsToNameSet $
,minf_modBreaks = emptyModBreaks
#endif
}
+
+ mb_guts <- if compile_to_core
+ then deSugarModule hsc_env ms tcg
+ else return Nothing
+
+ -- If we are loading this module so that we can typecheck
+ -- dependent modules, generate an interface and stuff it
+ -- all in the HomePackageTable.
+ when load $ do
+ (iface,_) <- makeSimpleIface hsc_env Nothing tcg details
+ let mod_info = HomeModInfo {
+ hm_iface = iface,
+ hm_details = details,
+ hm_linkable = Nothing }
+ let hpt_new = addToUFM (hsc_HPT hsc_env) mod mod_info
+ writeIORef ref hsc_env0{ hsc_HPT = hpt_new }
+
return (Just (CheckedModule {
- parsedSource = parsed,
- renamedSource = renamed,
+ parsedSource = rdr_module,
+ renamedSource = rn_info,
typecheckedSource = Just tc_binds,
checkedModuleInfo = Just minf,
- coreBinds = maybeCoreBinds}))
+ coreModule = mb_guts }))
-- | This is the way to get access to the Core bindings corresponding
-- to a module. 'compileToCore' invokes 'checkModule' to parse, typecheck, and
--- desugar the module, then returns the resulting list of Core bindings if
--- successful.
+-- desugar the module, then returns the resulting Core module (consisting of
+-- the module name, type declarations, and function declarations) if
+-- successful.
+compileToCoreModule :: Session -> FilePath -> IO (Maybe CoreModule)
+compileToCoreModule = compileCore False
+
+-- | Like compileToCoreModule, but invokes the simplifier, so
+-- as to return simplified and tidied Core.
+compileToCoreSimplified :: Session -> FilePath -> IO (Maybe CoreModule)
+compileToCoreSimplified = compileCore True
+
+-- | Provided for backwards-compatibility: compileToCore returns just the Core
+-- bindings, but for most purposes, you probably want to call
+-- compileToCoreModule.
compileToCore :: Session -> FilePath -> IO (Maybe [CoreBind])
compileToCore session fn = do
+ maybeCoreModule <- compileToCoreModule session fn
+ return $ fmap cm_binds maybeCoreModule
+
+-- | Takes a CoreModule and compiles the bindings therein
+-- to object code. The first argument is a bool flag indicating
+-- whether to run the simplifier.
+-- The resulting .o, .hi, and executable files, if any, are stored in the
+-- current directory, and named according to the module name.
+-- Returns True iff compilation succeeded.
+-- This has only so far been tested with a single self-contained module.
+compileCoreToObj :: Bool -> Session -> CoreModule -> IO Bool
+compileCoreToObj simplify session cm@(CoreModule{ cm_module = mName }) = do
+ hscEnv <- sessionHscEnv session
+ dflags <- getSessionDynFlags session
+ currentTime <- getClockTime
+ cwd <- getCurrentDirectory
+ modLocation <- mkHiOnlyModLocation dflags (hiSuf dflags) cwd
+ ((moduleNameSlashes . moduleName) mName)
+
+ let modSummary = ModSummary { ms_mod = mName,
+ ms_hsc_src = ExtCoreFile,
+ ms_location = modLocation,
+ -- By setting the object file timestamp to Nothing,
+ -- we always force recompilation, which is what we
+ -- want. (Thus it doesn't matter what the timestamp
+ -- for the (nonexistent) source file is.)
+ ms_hs_date = currentTime,
+ ms_obj_date = Nothing,
+ -- Only handling the single-module case for now, so no imports.
+ ms_srcimps = [],
+ ms_imps = [],
+ -- No source file
+ ms_hspp_file = "",
+ ms_hspp_opts = dflags,
+ ms_hspp_buf = Nothing
+ }
+
+ mbHscResult <- evalComp
+ ((if simplify then hscSimplify else return) (mkModGuts cm)
+ >>= hscNormalIface >>= hscWriteIface >>= hscOneShot)
+ (CompState{ compHscEnv=hscEnv,
+ compModSummary=modSummary,
+ compOldIface=Nothing})
+ return $ isJust mbHscResult
+
+-- Makes a "vanilla" ModGuts.
+mkModGuts :: CoreModule -> ModGuts
+mkModGuts coreModule = ModGuts {
+ mg_module = cm_module coreModule,
+ mg_boot = False,
+ mg_exports = [],
+ mg_deps = noDependencies,
+ mg_dir_imps = emptyModuleEnv,
+ mg_used_names = emptyNameSet,
+ mg_rdr_env = emptyGlobalRdrEnv,
+ mg_fix_env = emptyFixityEnv,
+ mg_types = emptyTypeEnv,
+ mg_insts = [],
+ mg_fam_insts = [],
+ mg_rules = [],
+ mg_binds = cm_binds coreModule,
+ mg_foreign = NoStubs,
+ mg_deprecs = NoDeprecs,
+ mg_hpc_info = emptyHpcInfo False,
+ mg_modBreaks = emptyModBreaks,
+ mg_vect_info = noVectInfo,
+ mg_inst_env = emptyInstEnv,
+ mg_fam_inst_env = emptyFamInstEnv
+}
+
+compileCore :: Bool -> Session -> FilePath -> IO (Maybe CoreModule)
+compileCore simplify session fn = do
-- First, set the target to the desired filename
target <- guessTarget fn Nothing
addTarget session target
case maybeModGraph of
Nothing -> return Nothing
Just modGraph -> do
- let modSummary = expectJust "compileToCore" $
- find ((== fn) . msHsFilePath) modGraph
- -- Now we have the module name;
- -- parse, typecheck and desugar the module
- let mod = ms_mod_name modSummary
- maybeCheckedModule <- checkModule session mod True
- case maybeCheckedModule of
+ case find ((== fn) . msHsFilePath) modGraph of
+ Just modSummary -> do
+ -- Now we have the module name;
+ -- parse, typecheck and desugar the module
+ let mod = ms_mod_name modSummary
+ maybeCheckedModule <- checkModule session mod True
+ case maybeCheckedModule of
Nothing -> return Nothing
- Just checkedMod -> return $ coreBinds checkedMod
- -- ---------------------------------------------------------------------------
+ Just checkedMod -> (liftM $ fmap gutsToCoreModule) $
+ case (coreModule checkedMod) of
+ Just mg | simplify -> (sessionHscEnv session)
+ -- If simplify is true: simplify (hscSimplify),
+ -- then tidy (tidyProgram).
+ >>= \ hscEnv -> evalComp (hscSimplify mg)
+ (CompState{ compHscEnv=hscEnv,
+ compModSummary=modSummary,
+ compOldIface=Nothing})
+ >>= (tidyProgram hscEnv)
+ >>= (return . Just . Left)
+ Just guts -> return $ Just $ Right guts
+ Nothing -> return Nothing
+ 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 :: Either (CgGuts, ModDetails) ModGuts -> CoreModule
+ gutsToCoreModule (Left (cg, md)) = CoreModule {
+ cm_module = cg_module cg, cm_types = md_types md,
+ cm_imports = cg_dir_imps cg, cm_binds = cg_binds cg
+ }
+ gutsToCoreModule (Right mg) = CoreModule {
+ cm_module = mg_module mg, cm_types = mg_types mg,
+ cm_imports = moduleEnvKeys (mg_dir_imps mg), cm_binds = mg_binds mg
+ }
+
+-- ---------------------------------------------------------------------------
-- Unloading
unload :: HscEnv -> [Linkable] -> IO ()
cleanup -- Remove unwanted tmp files between compilations
case mb_mod_info of
- Nothing -> return (Failed, hsc_env, [])
+ Nothing -> return (Failed, hsc_env, done)
Just mod_info -> do
let this_mod = ms_mod_name mod
warn :: Located ModuleName -> WarnMsg
warn (L loc mod) =
mkPlainErrMsg loc
- (ptext SLIT("Warning: {-# SOURCE #-} unnecessary in import of ")
+ (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ")
<+> quotes (ppr mod))
-----------------------------------------------------------------------------
Nothing -> packageModErr modl
Just s -> return s
- rootLoc = mkGeneralSrcSpan FSLIT("<command line>")
+ rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
-- In a root module, the filename is allowed to diverge from the module
-- name, so we have to check that there aren't multiple root files
let dflags = hsc_dflags hsc_env
(dflags', hspp_fn, buf)
- <- preprocessFile dflags file mb_phase maybe_buf
+ <- preprocessFile hsc_env file mb_phase maybe_buf
(srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
= do
-- Preprocess the source file and get its imports
-- The dflags' contains the OPTIONS pragmas
- (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf
+ (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf
(srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
when (mod_name /= wanted_mod) $
throwDyn $ mkPlainErrMsg mod_loc $
- text "file name does not match module name"
- <+> quotes (ppr mod_name)
+ text "File name does not match module name:"
+ $$ text "Saw:" <+> quotes (ppr mod_name)
+ $$ text "Expected:" <+> quotes (ppr wanted_mod)
-- Find the object timestamp, and return the summary
obj_timestamp <- getObjTimestamp location is_boot
else modificationTimeIfExists (ml_obj_file location)
-preprocessFile :: DynFlags -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime)
+preprocessFile :: HscEnv -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime)
-> IO (DynFlags, FilePath, StringBuffer)
-preprocessFile dflags src_fn mb_phase Nothing
+preprocessFile hsc_env src_fn mb_phase Nothing
= do
- (dflags', hspp_fn) <- preprocess dflags (src_fn, mb_phase)
+ (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
buf <- hGetStringBuffer hspp_fn
return (dflags', hspp_fn, buf)
-preprocessFile dflags src_fn mb_phase (Just (buf, _time))
+preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
= do
+ let dflags = hsc_dflags hsc_env
-- case we bypass the preprocessing stage?
let
- local_opts = getOptions buf src_fn
+ local_opts = getOptions dflags buf src_fn
--
- (dflags', _errs) <- parseDynamicFlags dflags (map unLoc local_opts)
- -- XXX: shouldn't we be reporting the errors?
+ (dflags', leftovers, warns) <- parseDynamicFlags dflags (map unLoc local_opts)
+ checkProcessArgsResult leftovers src_fn
+ handleFlagWarnings dflags' warns
let
needs_preprocessing
cyclicModuleErr :: [ModSummary] -> SDoc
cyclicModuleErr ms
- = hang (ptext SLIT("Module imports form a cycle for modules:"))
+ = hang (ptext (sLit "Module imports form a cycle for modules:"))
2 (vcat (map show_one ms))
where
show_one ms = sep [ show_mod (ms_hsc_src ms) (ms_mod ms),
- nest 2 $ ptext SLIT("imports:") <+>
+ nest 2 $ ptext (sLit "imports:") <+>
(pp_imps HsBootFile (ms_srcimps ms)
$$ pp_imps HsSrcFile (ms_imps ms))]
show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
return $! lookupType (hsc_dflags hsc_env)
(hsc_HPT hsc_env) (eps_PTE eps) name
+#ifdef GHCI
+-- | get the GlobalRdrEnv for a session
+getGRE :: Session -> IO GlobalRdrEnv
+getGRE s = withSession s $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env)
+#endif
+
-- -----------------------------------------------------------------------------
-- Misc exported utils