Use a MonadIO instance instead of an 'io' function
authorIan Lynagh <ian@well-typed.com>
Wed, 5 Dec 2012 22:46:33 +0000 (22:46 +0000)
committerIan Lynagh <ian@well-typed.com>
Wed, 5 Dec 2012 22:46:33 +0000 (22:46 +0000)
compiler/main/DriverPipeline.hs

index d0e1ca8..1fa36b5 100644 (file)
@@ -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