Fix CodingStyle#Warnings URLs

[ghc-hetmet.git] / compiler / main / DriverPipeline.hs

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index cf6bff1..ceb0b3b 100644 (file)
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -6,6 +6,13 @@
 --
 -----------------------------------------------------------------------------
 
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module DriverPipeline (
        -- Run a series of compilation steps in a pipeline, for a
        -- collection of source files.
@@ -327,7 +334,6 @@ link LinkBinary dflags batch_attempt_linking hpt
                                 text "   Main.main not exported; not linking.")
         return Succeeded
       
-
 -- -----------------------------------------------------------------------------
 -- Compile files in one-shot mode.
 
@@ -413,12 +419,16 @@ runPipeline
   -> Maybe ModLocation          -- A ModLocation, if this is a Haskell module
   -> IO (DynFlags, FilePath)   -- (final flags, output filename)
 
-runPipeline stop_phase dflags (input_fn, mb_phase) mb_basename output maybe_loc
+runPipeline stop_phase dflags0 (input_fn, mb_phase) mb_basename output maybe_loc
   = do
-  let (input_basename, suffix) = splitFilename input_fn
+  let
+      (input_basename, suffix) = splitFilename input_fn
       basename | Just b <- mb_basename = b
                | otherwise             = input_basename
 
+      -- Decide where dump files should go based on the pipeline output
+      dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }
+
        -- If we were given a -x flag, then use that phase to start from
       start_phase = fromMaybe (startPhase suffix) mb_phase
 
@@ -1231,6 +1241,8 @@ linkBinary dflags o_files dep_packages = do
                        ]
                    | otherwise               = []
 
+    rc_objs <- maybeCreateManifest dflags output_fn
+
     let (md_c_flags, _) = machdepCCOpts dflags
     SysTools.runLink dflags ( 
                       [ SysTools.Option verb
@@ -1243,6 +1255,7 @@ linkBinary dflags o_files dep_packages = do
                      ++ extra_ld_inputs
                      ++ lib_path_opts
                      ++ extra_ld_opts
+                      ++ rc_objs
 #ifdef darwin_TARGET_OS
                      ++ framework_path_opts
                      ++ framework_opts
@@ -1281,6 +1294,59 @@ exeFileName dflags
        "a.out"
 #endif
 
+maybeCreateManifest
+   :: DynFlags
+   -> FilePath                          -- filename of executable
+   -> IO [FilePath]                     -- extra objects to embed, maybe
+maybeCreateManifest dflags exe_filename = do
+#ifndef mingw32_TARGET_OS
+  return []
+#else
+  if not (dopt Opt_GenManifest dflags) then return [] else do
+
+  let manifest_filename = exe_filename `joinFileExt` "manifest"
+
+  writeFile manifest_filename $ 
+      "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++
+      "  <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++
+      "  <assemblyIdentity version=\"1.0.0.0\"\n"++
+      "     processorArchitecture=\"X86\"\n"++
+      "     name=\"" ++ basenameOf exe_filename ++ "\"\n"++
+      "     type=\"win32\"/>\n\n"++
+      "  <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++
+      "    <security>\n"++
+      "      <requestedPrivileges>\n"++
+      "        <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++
+      "        </requestedPrivileges>\n"++
+      "       </security>\n"++
+      "  </trustInfo>\n"++
+      "</assembly>\n"
+
+  -- Windows will fine the manifest file if it is named foo.exe.manifest.
+  -- However, for extra robustness, and so that we can move the binary around,
+  -- we can embed the manifest in the binary itself using windres:
+  if not (dopt Opt_EmbedManifest dflags) then return [] else do
+
+  rc_filename <- newTempName dflags "rc"
+  rc_obj_filename <- newTempName dflags (objectSuf dflags)
+
+  writeFile rc_filename $
+      "1 24 MOVEABLE PURE \"" ++ manifest_filename ++ "\"\n"
+        -- magic numbers :-)
+
+  let wr_opts = getOpts dflags opt_windres
+  runWindres dflags $ map SysTools.Option $
+        ["--input="++rc_filename, 
+         "--output="++rc_obj_filename,
+         "--output-format=coff"] 
+        ++ wr_opts
+        -- no FileOptions here: windres doesn't like seeing
+        -- backslashes, apparently
+
+  return [rc_obj_filename]
+#endif
+
+
 linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO ()
 linkDynLib dflags o_files dep_packages = do
     let verb = getVerbFlag dflags