annotateIO rewriteFile calls, disable wrapping on system messages.

- Now if a rewriteFile fails, we'll get a stack trace on -v. We should rewrite writeFileAtomic but it's in the wrong module and it would involve changing a lot of clients, so this is a more conservative change. - We no longer wrap error messages in top handler, so that the stacks look better. Signed-off-by: Edward Z. Yang <[email protected]>
haskell · Mar 3, 2017 · 0aa73b7 · 0aa73b7
1 parent d3c9673
commit 0aa73b7
Show file tree

Hide file tree

Showing 4 changed files with 46 additions and 25 deletions.
diff --git a/Cabal/Distribution/Compat/Stack.hs b/Cabal/Distribution/Compat/Stack.hs
@@ -4,13 +4,16 @@
 module Distribution.Compat.Stack (
     WithCallStack,
     CallStack,
+    annotateCallStackIO,
     withFrozenCallStack,
     withLexicalCallStack,
     callStack,
     prettyCallStack,
     parentSrcLocPrefix
 ) where
 
+import System.IO.Error
+
 #ifdef MIN_VERSION_base
 #if MIN_VERSION_base(4,8,1)
 #define GHC_STACK_SUPPORTED 1
@@ -94,3 +97,17 @@ withLexicalCallStack :: (a -> IO b) -> a -> IO b
 withLexicalCallStack f = f
 
 #endif
+
+-- | This function is for when you *really* want to add a call
+-- stack to raised IO, but you don't have a
+-- 'Distribution.Verbosity.Verbosity' so you can't use
+-- 'Distribution.Simple.Utils.annotateIO'.  If you have a 'Verbosity',
+-- please use that function instead.
+annotateCallStackIO :: WithCallStack (IO a -> IO a)
+annotateCallStackIO = modifyIOError f
+  where
+    f ioe = ioeSetErrorString ioe
+          . wrapCallStack
+          $ ioeGetErrorString ioe
+    wrapCallStack s =
+        prettyCallStack callStack ++ "\n" ++ s
diff --git a/Cabal/Distribution/Simple/Build.hs b/Cabal/Distribution/Simple/Build.hs
@@ -646,7 +646,7 @@ writeAutogenFiles verbosity pkg lbi clbi = do
 
   let pathsModulePath = autogenComponentModulesDir lbi clbi
                  </> ModuleName.toFilePath (autogenPathsModuleName pkg) <.> "hs"
-  rewriteFile pathsModulePath (Build.PathsModule.generate pkg lbi clbi)
+  rewriteFile verbosity pathsModulePath (Build.PathsModule.generate pkg lbi clbi)
 
   --TODO: document what we're doing here, and move it to its own function
   case clbi of
@@ -661,9 +661,10 @@ writeAutogenFiles verbosity pkg lbi clbi = do
             let sigPath = autogenComponentModulesDir lbi clbi
                       </> ModuleName.toFilePath mod_name <.> "hsig"
             createDirectoryIfMissingVerbose verbosity True (takeDirectory sigPath)
-            rewriteFile sigPath $ "{-# LANGUAGE NoImplicitPrelude #-}\n" ++
-                                  "signature " ++ display mod_name ++ " where"
+            rewriteFile verbosity sigPath $
+                "{-# LANGUAGE NoImplicitPrelude #-}\n" ++
+                "signature " ++ display mod_name ++ " where"
     _ -> return ()
 
   let cppHeaderPath = autogenComponentModulesDir lbi clbi </> cppHeaderName
-  rewriteFile cppHeaderPath (Build.Macros.generate pkg lbi clbi)
+  rewriteFile verbosity cppHeaderPath (Build.Macros.generate pkg lbi clbi)
diff --git a/Cabal/Distribution/Simple/Utils.hs b/Cabal/Distribution/Simple/Utils.hs
@@ -410,9 +410,7 @@ topHandlerWith cont prog =
               detail       = ioeGetErrorString ioe
           in wrapText (pname ++ ": " ++ file ++ detail)
         _ ->
-          -- Why not use the default handler? Because we want
-          -- to wrap the error message output.
-          wrapText (displaySomeException se)
+          displaySomeException se
 
 -- | BC wrapper around 'Exception.displayException'.
 displaySomeException :: Exception.Exception e => e -> String
@@ -582,9 +580,9 @@ withCallStackPrefix tracer verbosity s = withFrozenCallStack $
                 then "\n"
                 else ""
         else "") ++
-    (if traceWhen verbosity tracer
-        then "----\n" ++ prettyCallStack callStack ++ "\n"
-        else "") ++
+    (case traceWhen verbosity tracer of
+        Just pre -> pre ++ prettyCallStack callStack ++ "\n"
+        Nothing  -> "") ++
     s
 
 -- | When should we emit the call stack?  We always emit
@@ -600,10 +598,12 @@ data TraceWhen
     deriving (Eq)
 
 -- | Determine if we should emit a call stack.
-traceWhen :: Verbosity -> TraceWhen -> Bool
-traceWhen _ AlwaysTrace = True
-traceWhen v VerboseTrace = v >= verbose
-traceWhen v FlagTrace = isVerboseCallStack v
+-- If we trace, it also emits any prefix we should append.
+traceWhen :: Verbosity -> TraceWhen -> Maybe String
+traceWhen _ AlwaysTrace = Just ""
+traceWhen v VerboseTrace | v >= verbose         = Just ""
+traceWhen v FlagTrace    | isVerboseCallStack v = Just "----\n"
+traceWhen _ _ = Nothing
 
 -- | When should we output the marker?  Things like 'die'
 -- always get marked, but a 'NormalMark' will only be
@@ -1382,18 +1382,20 @@ withTempDirectoryEx _verbosity opts targetDir template f = withFrozenCallStack $
 -- update the file's modification time.
 --
 -- NB: the file is assumed to be ASCII-encoded.
-rewriteFile :: FilePath -> String -> IO ()
-rewriteFile path newContent =
+rewriteFile :: Verbosity -> FilePath -> String -> IO ()
+rewriteFile verbosity path newContent =
   flip catchIO mightNotExist $ do
-    existingContent <- readFile path
+    existingContent <- annotateIO verbosity $ readFile path
     _ <- evaluate (length existingContent)
     unless (existingContent == newContent) $
-      writeFileAtomic path (BS.Char8.pack newContent)
+      annotateIO verbosity $
+        writeFileAtomic path (BS.Char8.pack newContent)
   where
-    mightNotExist e | isDoesNotExistError e = writeFileAtomic path
-                                              (BS.Char8.pack newContent)
-                    | otherwise             = ioError e
-    _ = callStack -- TODO: attach call stack to exception
+    mightNotExist e | isDoesNotExistError e
+                    = annotateIO verbosity $ writeFileAtomic path
+                        (BS.Char8.pack newContent)
+                    | otherwise
+                    = ioError e
 
 -- | The path name that represents the current directory.
 -- In Unix, it's @\".\"@, but this is system-specific.

diff --git a/cabal-install/Distribution/Client/SetupWrapper.hs b/cabal-install/Distribution/Client/SetupWrapper.hs
@@ -692,7 +692,7 @@ getExternalSetupMethod verbosity options pkg bt = do
       customSetupLhs  = workingDir options </> "Setup.lhs"
 
   updateSetupScript cabalLibVersion _ =
-    rewriteFile setupHs (buildTypeScript cabalLibVersion)
+    rewriteFile verbosity setupHs (buildTypeScript cabalLibVersion)
 
   buildTypeScript :: Version -> String
   buildTypeScript cabalLibVersion = case bt of
@@ -888,8 +888,9 @@ getExternalSetupMethod verbosity options pkg bt = do
             }
       let ghcCmdLine = renderGhcOptions compiler platform ghcOptions
       when (useVersionMacros options') $
-        rewriteFile cppMacrosFile (generatePackageVersionMacros
-                                     [ pid | (_ipid, pid) <- selectedDeps ])
+        rewriteFile verbosity cppMacrosFile
+            (generatePackageVersionMacros
+                [ pid | (_ipid, pid) <- selectedDeps ])
       case useLoggingHandle options of
         Nothing          -> runDbProgram verbosity program progdb ghcCmdLine