[project @ 2000-10-30 18:13:15 by sewardj]

Move readIface from RnM to IO, and commensurate changes.  Also, add a
field to ModuleLocation to hold preprocessed source locations.

ghc/compiler/ghci/CmSummarise.lhs

@@ -14,6 +14,7 @@ where
 
 import List 		( nub )
 import Char		( ord, isAlphaNum )
+import Util		( unJust )
 import HscTypes		( ModuleLocation(..) )
 import FastTypes
 
@@ -81,9 +82,7 @@ summarise :: Module -> ModuleLocation -> IO ModSummary
 summarise mod location
    = if isModuleInThisPackage mod
 	then do 
-	    let source_fn = hs_preprocd_file location
-	    -- ToDo:
-	    -- ppsource_fn <- preprocess source_fn
+	    let source_fn = unJust (ml_hspp_file location) "summarise"
 	    modsrc <- readFile source_fn
             let imps = getImports modsrc
                 fp   = fingerprint modsrc

ghc/compiler/main/DriverPipeline.hs

 -----------------------------------------------------------------------------
--- $Id: DriverPipeline.hs,v 1.12 2000/10/30 13:46:24 sewardj Exp $
+-- $Id: DriverPipeline.hs,v 1.13 2000/10/30 18:13:15 sewardj Exp $
 --
 -- GHC Driver
 --
@@ -404,8 +404,8 @@ run_phase Hsc basename suff input_fn output_fn
 	ohi    <- readIORef v_Output_hi
 	hisuf  <- readIORef v_Hi_suf
 	let hifile = case ohi of
-			   Nothing -> current_dir ++ {-ToDo: modname!!-}basename
-					++ hisuf
+			   Nothing -> current_dir ++ "/" ++ basename
+					++ "." ++ hisuf
 			   Just fn -> fn
 
   -- figure out if the source has changed, for recompilation avoidance.
@@ -434,9 +434,10 @@ run_phase Hsc basename suff input_fn output_fn
 
    -- build a bogus ModuleLocation to pass to hscMain.
         let location = ModuleLocation {
-                          hs_preprocd_file = input_fn,
-                          hi_file = hifile,
-                          obj_file = o_file
+                          ml_hs_file   = Nothing,
+                          ml_hspp_file = Just input_fn,
+                          ml_hi_file   = Just hifile,
+                          ml_obj_file  = Just o_file
                        }
 
   -- get the DynFlags
@@ -727,10 +728,9 @@ compile summary old_iface hst hit pcs = do
 
    init_dyn_flags <- readIORef v_InitDynFlags
    writeIORef v_DynFlags init_dyn_flags
-   
-   let input_fn = case ms_ppsource summary of
-			Just (ppsource, fingerprint) -> ppsource
-			Nothing -> hs_preprocd_file (ms_location summary)
+
+   let location = ms_location summary   
+   let input_fn = unJust (ml_hs_file location) "compile:hs"
 
    when verb (hPutStrLn stderr ("compile: input file " ++ input_fn))
 
@@ -748,7 +748,7 @@ compile summary old_iface hst hit pcs = do
    -- run the compiler
    hsc_result <- hscMain dyn_flags{ hscOutName = output_fn } 
 			 (panic "compile:source_unchanged")
-                         (ms_location summary) old_iface hst hit pcs
+                         location old_iface hst hit pcs
 
    case hsc_result of {
       HscFail pcs -> return (CompErrs pcs);
@@ -761,7 +761,7 @@ compile summary old_iface hst hit pcs = do
 		Nothing -> return (CompOK details Nothing pcs);
 		Just iface -> do
 
-	   let (basename, _) = splitFilename (hs_preprocd_file (ms_location summary))
+	   let (basename, _) = splitFilename input_fn
 	   maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c
 	   let stub_unlinked = case maybe_stub_o of
 				  Nothing -> []

ghc/compiler/main/Finder.lhs

@@ -123,9 +123,10 @@ mkHomeModuleLocn mod_name basename source_fn = do
 
    return (Just (mkHomeModule mod_name,
                  ModuleLocation{
-		    hs_preprocd_file = source_fn,
-		    hi_file          = hifile,
-		    obj_file         = o_file
+                    ml_hspp_file = Nothing,
+		    ml_hs_file   = Just source_fn,
+		    ml_hi_file   = Just hifile,
+		    ml_obj_file  = Just o_file
 	         }
 	))
 
@@ -165,9 +166,10 @@ maybePackageModule mod_name = do
 	Just (pkg_name,path) -> 
 	    return (Just (mkModule mod_name pkg_name,
 			  ModuleLocation{ 
-				hs_preprocd_file = "error:_package_module;_no_source",
-				hi_file          = path ++ '/':hi,
-				obj_file         = "error:_package_module;_no_object"
+                                ml_hspp_file = Nothing,
+				ml_hs_file   = Nothing,
+				ml_hi_file   = Just (path ++ '/':hi),
+				ml_obj_file  = Nothing
 			   }
 		   ))
 

ghc/compiler/main/HscMain.lhs

@@ -41,6 +41,7 @@ import CodeOutput	( codeOutput )
 import Module		( ModuleName, moduleName, mkModuleInThisPackage )
 import CmdLineOpts
 import ErrUtils		( dumpIfSet_dyn )
+import Util		( unJust )
 import UniqSupply	( mkSplitUniqSupply )
 
 import Bag		( emptyBag )
@@ -93,9 +94,10 @@ hscMain
 
 hscMain dflags source_unchanged location maybe_old_iface hst hit pcs
  = do {
+      putStrLn ( "hscMain: location =\n" ++ show location);
       putStrLn "checking old iface ...";
       (pcs_ch, check_errs, (recomp_reqd, maybe_checked_iface))
-         <- checkOldIface dflags hit hst pcs (hi_file location)
+         <- checkOldIface dflags hit hst pcs (unJust (ml_hi_file location) "hscMain")
 			  source_unchanged maybe_old_iface;
       if check_errs then
          return (HscFail pcs_ch)
@@ -156,7 +158,8 @@ hscRecomp dflags location maybe_checked_iface hst hit pcs_ch
       ;
 --      putStrLn ("toInterp = " ++ show toInterp);
       -- PARSE
-      maybe_parsed <- myParseModule dflags (hs_preprocd_file location);
+      maybe_parsed 
+         <- myParseModule dflags (unJust (ml_hspp_file location) "hscRecomp:hspp");
       case maybe_parsed of {
          Nothing -> return (HscFail pcs_ch);
          Just rdr_module -> do {
@@ -205,7 +208,7 @@ hscRecomp dflags location maybe_checked_iface hst hit pcs_ch
                   Just (fif, sdoc) -> Just fif; Nothing -> Nothing
       ;
       -- Write the interface file
-      writeIface maybe_final_iface
+      writeIface (unJust (ml_hi_file location) "hscRecomp:hi") maybe_final_iface
       ;
       -- do the rest of code generation/emission
       (maybe_stub_h_filename, maybe_stub_c_filename, maybe_ibinds)

ghc/compiler/main/HscTypes.lhs

@@ -88,9 +88,10 @@ import UniqSupply	( UniqSupply )
 \begin{code}
 data ModuleLocation
    = ModuleLocation {
-	hs_preprocd_file :: FilePath,	-- location after preprocessing
-	hi_file          :: FilePath,
-	obj_file         :: FilePath
+        ml_hs_file   :: Maybe FilePath,
+        ml_hspp_file :: Maybe FilePath,  -- path of preprocessed source
+        ml_hi_file   :: Maybe FilePath,
+        ml_obj_file  :: Maybe FilePath
      }
      deriving Show
 

ghc/compiler/main/MkIface.lhs

@@ -605,23 +605,15 @@ diffDecls old_vers old_fixities new_fixities old new
 %************************************************************************
 
 \begin{code}
-writeIface :: Maybe ModIface -> IO ()
-writeIface Nothing
+writeIface :: FilePath -> Maybe ModIface -> IO ()
+writeIface hi_path Nothing
   = return ()
 
-writeIface (Just mod_iface)
-  = do	{ maybe_found <- findModule mod_name ;
-	; case maybe_found of {
-	    Nothing -> printErrs (text "Can't write interface file for" <+> ppr mod_name) ;
-	    Just (_, locn) ->
-
-    do	{ let filename = hi_file locn 
-	; if_hdl <- openFile filename WriteMode
+writeIface hi_path (Just mod_iface)
+  = do	{ if_hdl <- openFile hi_path WriteMode
 	; printForIface if_hdl (pprIface mod_iface)
 	; hClose if_hdl
-	}}}
-  where
-    mod_name = moduleName (mi_module mod_iface)
+	}
 	 
 pprIface :: ModIface -> SDoc
 pprIface iface

ghc/compiler/rename/Rename.lhs

@@ -17,13 +17,13 @@ import RnHsSyn		( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDe
 			  instDeclFVs, tyClDeclFVs, ruleDeclFVs
 			)
 
-import CmdLineOpts	( DynFlags, DynFlag(..) )
+import CmdLineOpts	( DynFlags, DynFlag(..), dopt )
 import RnMonad
 import RnNames		( getGlobalNames )
 import RnSource		( rnSourceDecls, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl )
 import RnIfaces		( slurpImpDecls, mkImportInfo, 
 			  getInterfaceExports, closeDecls,
-			  RecompileRequired, recompileRequired
+			  RecompileRequired, outOfDate, recompileRequired
 			)
 import RnHiFiles	( readIface, removeContext, 
 			  loadExports, loadFixDecls, loadDeprecs )
@@ -33,7 +33,8 @@ import RnEnv		( availName,
 			  lookupOrigNames, lookupGlobalRn, newGlobalName
 			)
 import Module           ( Module, ModuleName, WhereFrom(..),
-			  moduleNameUserString, moduleName, moduleEnvElts
+			  moduleNameUserString, moduleName,
+			  mkModuleInThisPackage, mkModuleName, moduleEnvElts
 			)
 import Name		( Name, isLocallyDefined, NamedThing(..), getSrcLoc,
 			  nameOccName, nameModule,
@@ -376,35 +377,41 @@ checkOldIface :: DynFlags
 				-- True <=> errors happened
 
 checkOldIface dflags hit hst pcs iface_path source_unchanged maybe_iface
-  = initRn dflags hit hst pcs (panic "checkOldIface: bogus mod") $
-	
-	-- Load the old interface file, if we havn't already got it
-    loadOldIface iface_path maybe_iface				`thenRn` \ maybe_iface2 ->
-
-	-- Check versions
-    recompileRequired iface_path source_unchanged maybe_iface2	`thenRn` \ recompile ->
-
-    returnRn (recompile, maybe_iface2)
+  = case maybe_iface of
+       Just old_iface -> -- Use the one we already have
+                         startRn (mi_module old_iface) $ 
+                         check_versions old_iface
+       Nothing -- try and read it from a file
+          -> do read_result <- readIface do_traceRn iface_path
+                case read_result of
+                   Left err -> -- Old interface file not found, or garbled; give up
+                               return (pcs, False, (outOfDate, Nothing))
+                   Right parsed_iface
+                      -> startRn (pi_mod parsed_iface) $
+                         loadOldIface parsed_iface `thenRn` \ m_iface ->
+                         check_versions m_iface
+    where
+       check_versions :: ModIface -> RnMG (RecompileRequired, Maybe ModIface)
+       check_versions iface
+          = -- Check versions
+            recompileRequired iface_path source_unchanged iface
+	 						`thenRn` \ recompile ->
+            returnRn (recompile, Just iface)
+
+       do_traceRn     = dopt Opt_D_dump_rn_trace dflags
+       ioTraceRn sdoc = if do_traceRn then printErrs sdoc else return ()
+       startRn mod     = initRn dflags hit hst pcs mod
 \end{code}
 
+I think the following function should now have a more representative name,
+but what?
 
 \begin{code}
-loadOldIface :: FilePath -> Maybe ModIface -> RnMG (Maybe ModIface)
-loadOldIface iface_path (Just iface) 
-  = returnRn (Just iface)
-
-loadOldIface iface_path Nothing
-  = 	-- LOAD THE OLD INTERFACE FILE
-    -- call readIface ...
-    readIface iface_path `thenRn` \ read_result ->
-    case read_result of {
-	Left err -> 	-- Old interface file not found, or garbled, so we'd better bail out
-		    traceRn (vcat [ptext SLIT("No old interface file:"), err])	`thenRn_`
-		    returnRn Nothing ;
-
-	Right iface ->
-
-	-- RENAME IT
+loadOldIface :: ParsedIface -> RnMG ModIface
+
+loadOldIface parsed_iface
+  = let iface = parsed_iface 
+    in	-- RENAME IT
     let mod = pi_mod iface
         doc_str = ptext SLIT("need usage info from") <+> ppr mod
     in
@@ -413,10 +420,11 @@ loadOldIface iface_path Nothing
 	loadHomeRules (pi_rules iface)	`thenRn` \ rules -> 
 	loadHomeInsts (pi_insts iface)	`thenRn` \ insts ->
 	returnRn (decls, rules, insts)
-    )				`thenRn` \ ((decls_vers, new_decls), (rule_vers, new_rules), new_insts) ->
+    )	
+	`thenRn` \ ((decls_vers, new_decls), (rule_vers, new_rules), new_insts) ->
 
     mapRn loadHomeUsage	(pi_usages iface)	`thenRn` \ usages ->
-    loadExports 	(pi_exports iface)	`thenRn` \ (export_vers, avails) ->
+    loadExports         (pi_exports iface)	`thenRn` \ (export_vers, avails) ->
     loadFixDecls mod	(pi_fixity iface)	`thenRn` \ fix_env ->
     loadDeprecs mod	(pi_deprecs iface)	`thenRn` \ deprec_env ->
     let
@@ -437,8 +445,7 @@ loadOldIface iface_path Nothing
 			       mi_globals = panic "No mi_globals in old interface"
 		    }
     in
-    returnRn (Just mod_iface)
-    }
+    returnRn mod_iface
 \end{code}
 
 \begin{code}

ghc/compiler/rename/RnHiFiles.lhs

@@ -17,7 +17,7 @@ module RnHiFiles (
 
 #include "HsVersions.h"
 
-import CmdLineOpts	( opt_IgnoreIfacePragmas )
+import CmdLineOpts	( DynFlag(..), opt_IgnoreIfacePragmas )
 import HscTypes		( ModuleLocation(..),
 			  ModIface(..), emptyModIface,
 			  VersionInfo(..),
@@ -57,10 +57,13 @@ import StringBuffer     ( hGetStringBuffer )
 import FastString	( mkFastString )
 import ErrUtils         ( Message )
 import Finder		( findModule )
+import Util		( unJust )
 import Lex
 import FiniteMap
 import Outputable
 import Bag
+
+import Monad		( when )
 \end{code}
 
 
@@ -468,8 +471,6 @@ getSysTyClDeclBinders mod other_decl
   = returnRn []
 \end{code}
 
-
-
 %*********************************************************
 %*							*
 \subsection{Reading an interface file}
@@ -487,10 +488,14 @@ findAndReadIface :: SDoc -> ModuleName
 findAndReadIface doc_str mod_name hi_boot_file
   = traceRn trace_msg			`thenRn_`
     ioToRnM (findModule mod_name)	`thenRn` \ maybe_found ->
-
+    doptRn Opt_D_dump_rn_trace		`thenRn` \ rn_trace ->
     case maybe_found of
       Right (Just (wanted_mod,locn))
-        -> readIface (hi_file locn ++ if hi_boot_file then "-boot" else "")
+        -> ioToRnM_no_fail (
+              readIface rn_trace 
+	         (unJust (ml_hi_file locn) "findAndReadIface"
+                  ++ if hi_boot_file then "-boot" else "")
+	   )
 					`thenRn` \ read_result ->
 	   case read_result of
               Left bad -> returnRn (Left bad)
@@ -515,30 +520,30 @@ findAndReadIface doc_str mod_name hi_boot_file
 @readIface@ tries just the one file.
 
 \begin{code}
-readIface :: String -> RnM d (Either Message ParsedIface)
+readIface :: Bool -> String -> IO (Either Message ParsedIface)
 	-- Nothing <=> file not found, or unreadable, or illegible
 	-- Just x  <=> successfully found and parsed 
-readIface file_path
-  = traceRn (ptext SLIT("readIFace") <+> text file_path)	`thenRn_`
-    ioToRnM (hGetStringBuffer False file_path)     		`thenRn` \ read_result ->
-    case read_result of
-	Right contents	  -> 
-             case parseIface contents
+readIface tr file_path
+  = when tr (printErrs (ptext SLIT("readIFace") <+> text file_path)) 
+    >>
+    ((hGetStringBuffer False file_path	>>= \ contents ->
+        case parseIface contents
 			PState{ bol = 0#, atbol = 1#,
 				context = [],
 				glasgow_exts = 1#,
 				loc = mkSrcLoc (mkFastString file_path) 1 } of
-		  POk _  (PIface iface) -> returnRn (Right iface)
+		  POk _  (PIface iface) -> return (Right iface)
 		  PFailed err   -> bale_out err
 	          parse_result 	-> bale_out empty
 		 	-- This last case can happen if the interface file is (say) empty
 			-- in which case the parser thinks it looks like an IdInfo or
 			-- something like that.  Just an artefact of the fact that the
 			-- parser is used for several purposes at once.
-
-        Left io_err -> bale_out (text (show io_err))
+   )
+   `catch` 
+   (\ io_err -> bale_out (text (show io_err))))
   where
-    bale_out err = returnRn (Left (badIfaceFile file_path err))
+    bale_out err = return (Left (badIfaceFile file_path err))
 \end{code}
 
 

ghc/compiler/rename/RnIfaces.lhs

@@ -787,9 +787,9 @@ outOfDate = True	-- Recompile required
 
 recompileRequired :: FilePath		-- Only needed for debug msgs
 		  -> Bool 		-- Source unchanged
-		  -> Maybe ModIface 	-- Old interface, if any
+		  -> ModIface 		-- Old interface
 		  -> RnMG RecompileRequired
-recompileRequired iface_path source_unchanged maybe_iface
+recompileRequired iface_path source_unchanged iface
   = traceRn (text "Considering whether compilation is required for" <+> text iface_path <> colon)	`thenRn_`
 
 	-- CHECK WHETHER THE SOURCE HAS CHANGED
@@ -799,12 +799,8 @@ recompileRequired iface_path source_unchanged maybe_iface
     else
 
 	-- CHECK WHETHER WE HAVE AN OLD IFACE
-    case maybe_iface of 
-	Nothing -> traceRn (nest 4 (ptext SLIT("No old interface file")))	`thenRn_`
-		   returnRn outOfDate ;
-
-	Just iface  ->    	-- Source code unchanged and no errors yet... carry on 
-			checkList [checkModUsage u | u <- mi_usages iface]
+	-- Source code unchanged and no errors yet... carry on 
+	checkList [checkModUsage u | u <- mi_usages iface]
 
 checkList :: [RnMG RecompileRequired] -> RnMG RecompileRequired
 checkList []		 = returnRn upToDate

ghc/compiler/rename/RnMonad.lhs

@@ -86,6 +86,12 @@ ioToRnM :: IO r -> RnM d (Either IOError r)
 ioToRnM io rn_down g_down = (io >>= \ ok -> return (Right ok)) 
 			    `catch` 
 			    (\ err -> return (Left err))
+
+ioToRnM_no_fail :: IO r -> RnM d r
+ioToRnM_no_fail io rn_down g_down 
+   = (io >>= \ ok -> return ok) 
+     `catch` 
+     (\ err -> panic "ioToRnM_no_fail: the I/O operation failed!")
 	    
 traceRn :: SDoc -> RnM d ()
 traceRn msg

ghc/compiler/utils/Util.lhs

@@ -24,6 +24,9 @@ module Util (
 	-- for-loop
 	nTimes,
 
+	-- maybe-ish
+	unJust,
+
 	-- sorting
 	IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
 	sortLt,
@@ -65,8 +68,8 @@ module Util (
 
 #include "HsVersions.h"
 
-import IO		( hPutStrLn, stderr )
 import List		( zipWith4 )
+import Maybe		( Maybe(..) )
 import Panic		( panic )
 import IOExts		( IORef, newIORef, unsafePerformIO )
 import FastTypes
@@ -128,6 +131,17 @@ nTimes 1 f = f
 nTimes n f = f . nTimes (n-1) f
 \end{code}
 
+%************************************************************************
+%*									*
+\subsection{Maybe-ery}
+%*									*
+%************************************************************************
+
+\begin{code}
+unJust :: Maybe a -> String -> a
+unJust (Just x) who = x
+unJust Nothing  who = panic ("unJust of Nothing, called by " ++ who)
+\end{code}
 
 %************************************************************************
 %*									*