Commit cf411c9a authored by Simon Marlow's avatar Simon Marlow

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.
parent 4564c112
...@@ -29,7 +29,7 @@ module DriverPipeline ( ...@@ -29,7 +29,7 @@ module DriverPipeline (
import Packages import Packages
import HeaderInfo import HeaderInfo
import DriverPhases import DriverPhases
import SysTools ( newTempName, addFilesToClean, copy ) import SysTools
import qualified SysTools import qualified SysTools
import HscMain import HscMain
import Finder import Finder
...@@ -442,17 +442,19 @@ runPipeline stop_phase dflags (input_fn, mb_phase) output maybe_loc ...@@ -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 -- 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 -- (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 -- 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 case output of
Temporary -> Temporary ->
return (dflags', output_fn) return (dflags', output_fn)
_other -> _other ->
do final_fn <- get_output_fn dflags' stop_phase maybe_loc do final_fn <- get_output_fn dflags' stop_phase maybe_loc
when (final_fn /= output_fn) $ when (final_fn /= output_fn) $ do
copy dflags ("Copying `" ++ output_fn ++ "' to `" ++ final_fn let msg = ("Copying `" ++ output_fn ++"' to `" ++ final_fn ++ "'")
++ "'") output_fn final_fn line_prag = Just ("{-# LINE 1 \"" ++ input_fn ++ "\" #-}\n")
copyWithHeader dflags msg line_prag output_fn final_fn
return (dflags', final_fn) return (dflags', final_fn)
pipeLoop :: DynFlags -> Phase -> Phase pipeLoop :: DynFlags -> Phase -> Phase
......
...@@ -19,7 +19,8 @@ module SysTools ( ...@@ -19,7 +19,8 @@ module SysTools (
runMkDLL, runMkDLL,
touch, -- String -> String -> IO () touch, -- String -> String -> IO ()
copy, -- String -> String -> String -> IO () copy,
copyWithHeader,
normalisePath, -- FilePath -> FilePath normalisePath, -- FilePath -> FilePath
-- Temporary-file management -- Temporary-file management
...@@ -469,15 +470,21 @@ touch :: DynFlags -> String -> String -> IO () ...@@ -469,15 +470,21 @@ touch :: DynFlags -> String -> String -> IO ()
touch dflags purpose arg = touch dflags purpose arg =
runSomething dflags purpose (pgm_T dflags) [FileOption "" arg] runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
copy :: DynFlags -> String -> String -> String -> IO () copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
copy dflags purpose from to = do 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 showPass dflags purpose
h <- openFile to WriteMode h <- openFile to WriteMode
ls <- readFile from -- inefficient, but it'll do for now. ls <- readFile from -- inefficient, but it'll do for now.
-- ToDo: speed up via slurping. -- ToDo: speed up via slurping.
maybe (return ()) (hPutStr h) maybe_header
hPutStr h ls hPutStr h ls
hClose h hClose h
\end{code} \end{code}
%************************************************************************ %************************************************************************
......
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