From cf411c9ae5d61d6e5baa5e5e6b0ad9803b041236 Mon Sep 17 00:00:00 2001
From: Simon Marlow <simonmar@microsoft.com>
Date: Thu, 15 Feb 2007 11:58:52 +0000
Subject: [PATCH] When the pipeline just copies the file, prepend a LINE
 pragma For example, "ghc -E Foo.hs -o Foo.bar" just copies
 Foo.hs to Foo.bar.  This patch adds a LINE pragma to the
 beginning of Foo.bar so that further processing can track
 the location of the original file.

The motiviation for this is bug #1044.  When generating Haddock docs,
we preprocess the .hs to a .raw-hs, sometimes this doesn't involve any
actual preprocessing and in those cases we lose track of the original
filename.
---
 compiler/main/DriverPipeline.hs |   14 ++++++++------
 compiler/main/SysTools.lhs      |   13 ++++++++++---
 2 files changed, 18 insertions(+), 9 deletions(-)

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 59f0721..1ee2924 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -29,7 +29,7 @@ module DriverPipeline (
 import Packages
 import HeaderInfo
 import DriverPhases
-import SysTools		( newTempName, addFilesToClean, copy )
+import SysTools
 import qualified SysTools	
 import HscMain
 import Finder
@@ -442,17 +442,19 @@ runPipeline stop_phase dflags (input_fn, mb_phase) output maybe_loc
   -- Sometimes, a compilation phase doesn't actually generate any output
   -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this
   -- stage, but we wanted to keep the output, then we have to explicitly
-  -- copy the file.
+  -- copy the file, remembering to prepend a {-# LINE #-} pragma so that
+  -- further compilation stages can tell what the original filename was.
   case output of
     Temporary -> 
 	return (dflags', output_fn)
     _other ->
 	do final_fn <- get_output_fn dflags' stop_phase maybe_loc
-	   when (final_fn /= output_fn) $
-		  copy dflags ("Copying `" ++ output_fn ++ "' to `" ++ final_fn
-			++ "'") output_fn final_fn
+	   when (final_fn /= output_fn) $ do
+              let msg = ("Copying `" ++ output_fn ++"' to `" ++ final_fn ++ "'")
+                  line_prag = Just ("{-# LINE 1 \"" ++ input_fn ++ "\" #-}\n")
+	      copyWithHeader dflags msg line_prag output_fn final_fn
 	   return (dflags', final_fn)
-	        
+
 
 
 pipeLoop :: DynFlags -> Phase -> Phase 
diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs
index e44ed6d..9885b8d 100644
--- a/compiler/main/SysTools.lhs
+++ b/compiler/main/SysTools.lhs
@@ -19,7 +19,8 @@ module SysTools (
 	runMkDLL,
 
 	touch,			-- String -> String -> IO ()
-	copy,			-- String -> String -> String -> IO ()
+	copy,
+        copyWithHeader,
 	normalisePath,          -- FilePath -> FilePath
 	
 	-- Temporary-file management
@@ -469,15 +470,21 @@ touch :: DynFlags -> String -> String -> IO ()
 touch dflags purpose arg =
   runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
 
-copy :: DynFlags -> String -> String -> String -> IO ()
-copy dflags purpose from to = do
+copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
+copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
+
+copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
+               -> IO ()
+copyWithHeader dflags purpose maybe_header from to = do
   showPass dflags purpose
 
   h <- openFile to WriteMode
   ls <- readFile from -- inefficient, but it'll do for now.
 	    	      -- ToDo: speed up via slurping.
+  maybe (return ()) (hPutStr h) maybe_header
   hPutStr h ls
   hClose h
+
 \end{code}
 
 %************************************************************************
-- 
1.7.10.4