X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FDriverMkDepend.hs;h=ef28c2cb30834f4a319d7451e872db3d779137da;hb=bf925fd826e0f7b8a9d58073dbabe0d755ef0266;hp=1b3792e788111c69330da76662bf1167a0e42e8c;hpb=90c32262025049ae3013e8af1e9960756dace72d;p=ghc-hetmet.git

diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs
index 1b3792e..ef28c2c 100644
--- a/compiler/main/DriverMkDepend.hs
+++ b/compiler/main/DriverMkDepend.hs
@@ -16,10 +16,10 @@ module DriverMkDepend (
 #include "HsVersions.h"
 
 import qualified GHC
-import GHC              ( Session, ModSummary(..) )
+import GHC              ( ModSummary(..), GhcMonad )
 import DynFlags
 import Util
-import HscTypes         ( HscEnv, IsBootInterface, msObjFilePath, msHsFilePath )
+import HscTypes         ( HscEnv, IsBootInterface, msObjFilePath, msHsFilePath, getSession )
 import SysTools         ( newTempName )
 import qualified SysTools
 import Module
@@ -31,10 +31,10 @@ import SrcLoc
 import Data.List
 import FastString
 
+import Exception
 import ErrUtils         ( debugTraceMsg, putMsg )
+import MonadUtils       ( liftIO )
 
-import Control.Exception
-import System.Exit      ( ExitCode(..), exitWith )
 import System.Directory
 import System.FilePath
 import System.IO
@@ -48,37 +48,42 @@ import Data.Maybe       ( isJust )
 --
 -----------------------------------------------------------------
 
-doMkDependHS :: Session -> [FilePath] -> IO ()
-doMkDependHS session srcs
-  = do  {       -- Initialisation
-          dflags <- GHC.getSessionDynFlags session
-        ; files <- beginMkDependHS dflags
-
-                -- Do the downsweep to find all the modules
-        ; targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs
-        ; GHC.setTargets session targets
-        ; let excl_mods = depExcludeMods dflags
-        ; r <- GHC.depanal session excl_mods True {- Allow dup roots -}
-        ; case r of
-            Nothing -> exitWith (ExitFailure 1)
-            Just mod_summaries -> do {
+doMkDependHS :: GhcMonad m => [FilePath] -> m ()
+doMkDependHS srcs = do
+    -- Initialisation
+    dflags <- GHC.getSessionDynFlags
+    files <- liftIO $ beginMkDependHS dflags
+
+    -- Do the downsweep to find all the modules
+    targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs
+    GHC.setTargets targets
+    let excl_mods = depExcludeMods dflags
+    mod_summaries <- GHC.depanal excl_mods True {- Allow dup roots -}
+
+    -- Sort into dependency order
+    -- There should be no cycles
+    let sorted = GHC.topSortModuleGraph False mod_summaries Nothing
+
+    -- Print out the dependencies if wanted
+    liftIO $ debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted)
 
-                -- Sort into dependency order
-                -- There should be no cycles
-          let sorted = GHC.topSortModuleGraph False mod_summaries Nothing
+    -- Prcess them one by one, dumping results into makefile
+    -- and complaining about cycles
+    hsc_env <- getSession
+    mapM (liftIO . processDeps dflags hsc_env excl_mods (mkd_tmp_hdl files)) sorted
 
-                -- Print out the dependencies if wanted
-        ; debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted)
+    -- If -ddump-mod-cycles, show cycles in the module graph
+    liftIO $ dumpModCycles dflags mod_summaries
 
-                -- Prcess them one by one, dumping results into makefile
-                -- and complaining about cycles
-        ; mapM (processDeps dflags session excl_mods (mkd_tmp_hdl files)) sorted
+    -- Tidy up
+    liftIO $ endMkDependHS dflags files
 
-                -- If -ddump-mod-cycles, show cycles in the module graph
-        ; dumpModCycles dflags mod_summaries
+    -- Unconditional exiting is a bad idea.  If an error occurs we'll get an
+    --exception; if that is not caught it's fine, but at least we have a
+    --chance to find out exactly what went wrong.  Uncomment the following
+    --line if you disagree.
 
-                -- Tidy up
-        ; endMkDependHS dflags files }}
+    --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1)
 
 -----------------------------------------------------------------
 --
@@ -127,9 +132,9 @@ beginMkDependHS dflags = do
                         then return ()
                         else chuck
 
-           catchJust ioErrors slurp
+           catchIO slurp
                 (\e -> if isEOFError e then return () else ioError e)
-           catchJust ioErrors chuck
+           catchIO chuck
                 (\e -> if isEOFError e then return () else ioError e)
 
            return (Just makefile_hdl)
@@ -149,7 +154,7 @@ beginMkDependHS dflags = do
 -----------------------------------------------------------------
 
 processDeps :: DynFlags
-            -> Session
+            -> HscEnv
             -> [ModuleName]
             -> Handle           -- Write dependencies to here
             -> SCC ModSummary
@@ -171,11 +176,10 @@ processDeps :: DynFlags
 
 processDeps _ _ _ _ (CyclicSCC nodes)
   =     -- There shouldn't be any cycles; report them
-    throwDyn (ProgramError (showSDoc $ GHC.cyclicModuleErr nodes))
+    ghcError (ProgramError (showSDoc $ GHC.cyclicModuleErr nodes))
 
-processDeps dflags session excl_mods hdl (AcyclicSCC node)
-  = do  { hsc_env <- GHC.sessionHscEnv session
-        ; let extra_suffixes = depSuffixes dflags
+processDeps dflags hsc_env excl_mods hdl (AcyclicSCC node)
+  = do  { let extra_suffixes = depSuffixes dflags
               include_pkg_deps = depIncludePkgDeps dflags
               src_file  = msHsFilePath node
               obj_file  = msObjFilePath node
@@ -296,7 +300,7 @@ endMkDependHS dflags
                 hPutStrLn tmp_hdl l
                 slurp
 
-        catchJust ioErrors slurp
+        catchIO slurp
                 (\e -> if isEOFError e then return () else ioError e)
 
         hClose hdl