Commit d842dffa authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files

Use a MonadIO instance instead of an 'io' function

parent b25d7090
......@@ -617,16 +617,16 @@ instance Monad CompPipeline where
P m >>= k = P $ \env state -> do (state',a) <- m env state
unP (k a) env state'
io :: IO a -> CompPipeline a
io m = P $ \_env state -> do a <- m; return (state, a)
instance MonadIO CompPipeline where
liftIO m = P $ \_env state -> do a <- m; return (state, a)
phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath
phaseOutputFilename next_phase = do
PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv
PipeState{maybe_loc, hsc_env} <- getPipeState
let dflags = hsc_dflags hsc_env
io $ getOutputFilename stop_phase output_spec
src_basename dflags next_phase maybe_loc
liftIO $ getOutputFilename stop_phase output_spec
src_basename dflags next_phase maybe_loc
-- ---------------------------------------------------------------------------
-- outer pipeline loop
......@@ -649,8 +649,8 @@ pipeLoop phase input_fn = do
" but I wanted to stop at phase " ++ show stop_phase)
| otherwise
-> do io $ debugTraceMsg (hsc_dflags hsc_env) 4
(ptext (sLit "Running phase") <+> ppr phase)
-> do liftIO $ debugTraceMsg (hsc_dflags hsc_env) 4
(ptext (sLit "Running phase") <+> ppr phase)
dflags <- getDynFlags
(next_phase, output_fn) <- runPhase phase input_fn dflags
pipeLoop next_phase output_fn
......@@ -747,7 +747,7 @@ runPhase (Unlit sf) input_fn dflags
, SysTools.FileOption "" output_fn
]
io $ SysTools.runUnlit dflags flags
liftIO $ SysTools.runUnlit dflags flags
return (Cpp sf, output_fn)
where
......@@ -770,29 +770,32 @@ runPhase (Unlit sf) input_fn dflags
runPhase (Cpp sf) input_fn dflags0
= do
src_opts <- io $ getOptionsFromFile dflags0 input_fn
src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
(dflags1, unhandled_flags, warns)
<- io $ parseDynamicFilePragma dflags0 src_opts
<- liftIO $ parseDynamicFilePragma dflags0 src_opts
setDynFlags dflags1
io $ checkProcessArgsResult dflags1 unhandled_flags
liftIO $ checkProcessArgsResult dflags1 unhandled_flags
if not (xopt Opt_Cpp dflags1) then do
-- we have to be careful to emit warnings only once.
unless (gopt Opt_Pp dflags1) $ io $ handleFlagWarnings dflags1 warns
unless (gopt Opt_Pp dflags1) $
liftIO $ handleFlagWarnings dflags1 warns
-- no need to preprocess CPP, just pass input file along
-- to the next phase of the pipeline.
return (HsPp sf, input_fn)
else do
output_fn <- phaseOutputFilename (HsPp sf)
io $ doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn
liftIO $ doCpp dflags1 True{-raw-} False{-no CC opts-}
input_fn output_fn
-- re-read the pragmas now that we've preprocessed the file
-- See #2464,#3457
src_opts <- io $ getOptionsFromFile dflags0 output_fn
src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn
(dflags2, unhandled_flags, warns)
<- io $ parseDynamicFilePragma dflags0 src_opts
io $ checkProcessArgsResult dflags2 unhandled_flags
unless (gopt Opt_Pp dflags2) $ io $ handleFlagWarnings dflags2 warns
<- liftIO $ parseDynamicFilePragma dflags0 src_opts
liftIO $ checkProcessArgsResult dflags2 unhandled_flags
unless (gopt Opt_Pp dflags2) $
liftIO $ handleFlagWarnings dflags2 warns
-- the HsPp pass below will emit warnings
setDynFlags dflags2
......@@ -813,7 +816,7 @@ runPhase (HsPp sf) input_fn dflags
PipeEnv{src_basename, src_suffix} <- getPipeEnv
let orig_fn = src_basename <.> src_suffix
output_fn <- phaseOutputFilename (Hsc sf)
io $ SysTools.runPp dflags
liftIO $ SysTools.runPp dflags
( [ SysTools.Option orig_fn
, SysTools.Option input_fn
, SysTools.FileOption "" output_fn
......@@ -822,12 +825,12 @@ runPhase (HsPp sf) input_fn dflags
)
-- re-read pragmas now that we've parsed the file (see #3674)
src_opts <- io $ getOptionsFromFile dflags output_fn
src_opts <- liftIO $ getOptionsFromFile dflags output_fn
(dflags1, unhandled_flags, warns)
<- io $ parseDynamicFilePragma dflags src_opts
<- liftIO $ parseDynamicFilePragma dflags src_opts
setDynFlags dflags1
io $ checkProcessArgsResult dflags1 unhandled_flags
io $ handleFlagWarnings dflags1 warns
liftIO $ checkProcessArgsResult dflags1 unhandled_flags
liftIO $ handleFlagWarnings dflags1 warns
return (Hsc sf, output_fn)
......@@ -853,7 +856,7 @@ runPhase (Hsc src_flavour) input_fn dflags0
setDynFlags dflags
-- gather the imports and module name
(hspp_buf,mod_name,imps,src_imps) <- io $
(hspp_buf,mod_name,imps,src_imps) <- liftIO $
case src_flavour of
ExtCoreFile -> do -- no explicit imports in ExtCore input.
m <- getCoreModuleName input_fn
......@@ -870,7 +873,7 @@ runPhase (Hsc src_flavour) input_fn dflags0
-- the .hi and .o filenames, and this is as good a way
-- as any to generate them, and better than most. (e.g. takes
-- into accout the -osuf flags)
location1 <- io $ mkHomeModLocation2 dflags mod_name basename suff
location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff
-- Boot-ify it if necessary
let location2 | isHsBoot src_flavour = addBootSuffixLocn location1
......@@ -906,10 +909,10 @@ runPhase (Hsc src_flavour) input_fn dflags0
-- changed (which the compiler itself figures out).
-- Setting source_unchanged to False tells the compiler that M.o is out of
-- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
src_timestamp <- io $ getModificationUTCTime (basename <.> suff)
src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff)
let hsc_lang = hscTarget dflags
source_unchanged <- io $
source_unchanged <- liftIO $
if not (isStopLn stop)
-- SourceModified unconditionally if
-- (a) recompilation checker is off, or
......@@ -936,7 +939,7 @@ runPhase (Hsc src_flavour) input_fn dflags0
PipeState{hsc_env=hsc_env'} <- getPipeState
-- Tell the finder cache about this module
mod <- io $ addHomeModuleToFinder hsc_env' mod_name location4
mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location4
-- Make the ModSummary to hand to hscMain
let
......@@ -952,14 +955,14 @@ runPhase (Hsc src_flavour) input_fn dflags0
ms_srcimps = src_imps }
-- run the compiler!
result <- io $ hscCompileOneShot hsc_env'
mod_summary source_unchanged
Nothing -- No iface
Nothing -- No "module i of n" progress info
result <- liftIO $ hscCompileOneShot hsc_env'
mod_summary source_unchanged
Nothing -- No iface
Nothing -- No "module i of n" progress info
case result of
HscNoRecomp
-> do io $ touchObjectFile dflags' o_file
-> do liftIO $ touchObjectFile dflags' o_file
-- The .o file must have a later modification date
-- than the source file (else we wouldn't be in HscNoRecomp)
-- but we touch it anyway, to keep 'make' happy (we think).
......@@ -968,12 +971,12 @@ runPhase (Hsc src_flavour) input_fn dflags0
-> do case hasStub of
Nothing -> return ()
Just stub_c ->
do stub_o <- io $ compileStub hsc_env' stub_c
setStubO stub_o
do stub_o <- liftIO $ compileStub hsc_env' stub_c
setStubO stub_o
-- In the case of hs-boot files, generate a dummy .o-boot
-- stamp file for the benefit of Make
when (isHsBoot src_flavour) $
io $ touchObjectFile dflags' o_file
liftIO $ touchObjectFile dflags' o_file
return (next_phase, output_fn)
-----------------------------------------------------------------------------
......@@ -982,8 +985,8 @@ runPhase (Hsc src_flavour) input_fn dflags0
runPhase CmmCpp input_fn dflags
= do
output_fn <- phaseOutputFilename Cmm
io $ doCpp dflags False{-not raw-} True{-include CC opts-}
input_fn output_fn
liftIO $ doCpp dflags False{-not raw-} True{-include CC opts-}
input_fn output_fn
return (Cmm, output_fn)
runPhase Cmm input_fn dflags
......@@ -1002,7 +1005,7 @@ runPhase Cmm input_fn dflags
setDynFlags dflags'
PipeState{hsc_env} <- getPipeState
io $ hscCompileCmmFile hsc_env input_fn
liftIO $ hscCompileCmmFile hsc_env input_fn
return (next_phase, output_fn)
......@@ -1022,12 +1025,12 @@ runPhase cc_phase input_fn dflags
let cmdline_include_paths = includePaths dflags
-- HC files have the dependent packages stamped into them
pkgs <- if hcc then io $ getHCFilePackages input_fn else return []
pkgs <- if hcc then liftIO $ getHCFilePackages input_fn else return []
-- add package include paths even if we're just compiling .c
-- files; this is the Value Add(TM) that using ghc instead of
-- gcc gives you :)
pkg_include_dirs <- io $ getPackageIncludePath dflags pkgs
pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs
let include_paths = foldr (\ x xs -> "-I" : x : xs) []
(cmdline_include_paths ++ pkg_include_dirs)
......@@ -1039,7 +1042,7 @@ runPhase cc_phase input_fn dflags
-- cc-options are not passed when compiling .hc files. Our
-- hc code doesn't not #include any header files anyway, so these
-- options aren't necessary.
pkg_extra_cc_opts <- io $
pkg_extra_cc_opts <- liftIO $
if cc_phase `eqPhase` HCc
then return []
else getPackageExtraCcOpts dflags pkgs
......@@ -1047,7 +1050,7 @@ runPhase cc_phase input_fn dflags
framework_paths <-
case platformOS platform of
OSDarwin ->
do pkgFrameworkPaths <- io $ getPackageFrameworkPath dflags pkgs
do pkgFrameworkPaths <- liftIO $ getPackageFrameworkPath dflags pkgs
let cmdlineFrameworkPaths = frameworkPaths dflags
return $ map ("-F"++)
(cmdlineFrameworkPaths ++ pkgFrameworkPaths)
......@@ -1086,7 +1089,7 @@ runPhase cc_phase input_fn dflags
| cc_phase `eqPhase` Cobjc = "objective-c"
| cc_phase `eqPhase` Cobjcpp = "objective-c++"
| otherwise = "c"
io $ SysTools.runCc dflags (
liftIO $ SysTools.runCc dflags (
-- force the C compiler to interpret this file as C when
-- compiling .hc files, by adding the -x c option.
-- Also useful for plain .c files, just in case GHC saw a
......@@ -1145,25 +1148,26 @@ runPhase cc_phase input_fn dflags
runPhase Splitter input_fn dflags
= do -- tmp_pfx is the prefix used for the split .s files
split_s_prefix <- io $ SysTools.newTempName dflags "split"
split_s_prefix <- liftIO $ SysTools.newTempName dflags "split"
let n_files_fn = split_s_prefix
io $ SysTools.runSplit dflags
liftIO $ SysTools.runSplit dflags
[ SysTools.FileOption "" input_fn
, SysTools.FileOption "" split_s_prefix
, SysTools.FileOption "" n_files_fn
]
-- Save the number of split files for future references
s <- io $ readFile n_files_fn
s <- liftIO $ readFile n_files_fn
let n_files = read s :: Int
dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) }
setDynFlags dflags'
-- Remember to delete all these files
io $ addFilesToClean dflags' [ split_s_prefix ++ "__" ++ show n ++ ".s"
| n <- [1..n_files]]
liftIO $ addFilesToClean dflags'
[ split_s_prefix ++ "__" ++ show n ++ ".s"
| n <- [1..n_files]]
return (SplitAs,
"**splitter**") -- we don't use the filename in SplitAs
......@@ -1179,7 +1183,7 @@ runPhase As input_fn dflags
let whichAsProg | hscTarget dflags == HscLlvm &&
platformOS (targetPlatform dflags) == OSDarwin
= do
llvmVer <- io $ figureLlvmVersion dflags
llvmVer <- liftIO $ figureLlvmVersion dflags
return $ case llvmVer of
Just n | n >= 30 ->
(SysTools.runClang, getOpts dflags opt_c)
......@@ -1197,9 +1201,9 @@ runPhase As input_fn dflags
-- we create directories for the object file, because it
-- might be a hierarchical module.
io $ createDirectoryIfMissing True (takeDirectory output_fn)
liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
io $ as_prog dflags
liftIO $ as_prog dflags
(map SysTools.Option as_opts
++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
......@@ -1236,12 +1240,12 @@ runPhase SplitAs _input_fn dflags
osuf = objectSuf dflags
split_odir = base_o ++ "_" ++ osuf ++ "_split"
io $ createDirectoryIfMissing True split_odir
liftIO $ createDirectoryIfMissing True split_odir
-- remove M_split/ *.o, because we're going to archive M_split/ *.o
-- later and we don't want to pick up any old objects.
fs <- io $ getDirectoryContents split_odir
io $ mapM_ removeFile $
fs <- liftIO $ getDirectoryContents split_odir
liftIO $ mapM_ removeFile $
map (split_odir </>) $ filter (osuf `isSuffixOf`) fs
let as_opts = getOpts dflags opt_a
......@@ -1277,7 +1281,7 @@ runPhase SplitAs _input_fn dflags
, SysTools.FileOption "" (split_s n)
])
io $ mapM_ assemble_file [1..n]
liftIO $ mapM_ assemble_file [1..n]
-- Note [pipeline-split-init]
-- If we have a stub file, it may contain constructor
......@@ -1295,7 +1299,7 @@ runPhase SplitAs _input_fn dflags
PipeState{maybe_stub_o} <- getPipeState
case maybe_stub_o of
Nothing -> return ()
Just stub_o -> io $ do
Just stub_o -> liftIO $ do
tmp_split_1 <- newTempName dflags osuf
let split_1 = split_obj 1
copyFile split_1 tmp_split_1
......@@ -1303,7 +1307,7 @@ runPhase SplitAs _input_fn dflags
joinObjectFiles dflags [tmp_split_1, stub_o] split_1
-- join them into a single .o file
io $ joinObjectFiles dflags (map split_obj [1..n]) output_fn
liftIO $ joinObjectFiles dflags (map split_obj [1..n]) output_fn
return (next_phase, output_fn)
......@@ -1312,7 +1316,7 @@ runPhase SplitAs _input_fn dflags
runPhase LlvmOpt input_fn dflags
= do
ver <- io $ readIORef (llvmVersion dflags)
ver <- liftIO $ readIORef (llvmVersion dflags)
let lo_opts = getOpts dflags opt_lo
opt_lvl = max 0 (min 2 $ optLevel dflags)
......@@ -1330,7 +1334,7 @@ runPhase LlvmOpt input_fn dflags
output_fn <- phaseOutputFilename LlvmLlc
io $ SysTools.runLlvmOpt dflags
liftIO $ SysTools.runLlvmOpt dflags
([ SysTools.FileOption "" input_fn,
SysTools.Option "-o",
SysTools.FileOption "" output_fn]
......@@ -1349,7 +1353,7 @@ runPhase LlvmOpt input_fn dflags
runPhase LlvmLlc input_fn dflags
= do
ver <- io $ readIORef (llvmVersion dflags)
ver <- liftIO $ readIORef (llvmVersion dflags)
let lc_opts = getOpts dflags opt_lc
opt_lvl = max 0 (min 2 $ optLevel dflags)
......@@ -1368,7 +1372,7 @@ runPhase LlvmLlc input_fn dflags
output_fn <- phaseOutputFilename next_phase
io $ SysTools.runLlvmLlc dflags
liftIO $ SysTools.runLlvmLlc dflags
([ SysTools.Option (llvmOpts !! opt_lvl),
SysTools.Option $ "-relocation-model=" ++ rmodel,
SysTools.FileOption "" input_fn,
......@@ -1409,7 +1413,7 @@ runPhase LlvmMangle input_fn dflags
= do
let next_phase = if gopt Opt_SplitObjs dflags then Splitter else As
output_fn <- phaseOutputFilename next_phase
io $ llvmFixupAsm dflags input_fn output_fn
liftIO $ llvmFixupAsm dflags input_fn output_fn
return (next_phase, output_fn)
-----------------------------------------------------------------------------
......@@ -1423,7 +1427,7 @@ runPhase MergeStub input_fn dflags
Nothing ->
panic "runPhase(MergeStub): no stub"
Just stub_o -> do
io $ joinObjectFiles dflags [input_fn, stub_o] output_fn
liftIO $ joinObjectFiles dflags [input_fn, stub_o] output_fn
return (StopLn, output_fn)
-- warning suppression
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment