From 0aa73b785c755d503162da2761ee7839c352e91f Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Fri, 3 Mar 2017 15:37:39 -0800 Subject: [PATCH] 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 --- Cabal/Distribution/Compat/Stack.hs | 17 +++++++++ Cabal/Distribution/Simple/Build.hs | 9 +++-- Cabal/Distribution/Simple/Utils.hs | 38 ++++++++++--------- .../Distribution/Client/SetupWrapper.hs | 7 ++-- 4 files changed, 46 insertions(+), 25 deletions(-) diff --git a/Cabal/Distribution/Compat/Stack.hs b/Cabal/Distribution/Compat/Stack.hs index 98e8159982d..0ed0da2e43e 100644 --- a/Cabal/Distribution/Compat/Stack.hs +++ b/Cabal/Distribution/Compat/Stack.hs @@ -4,6 +4,7 @@ module Distribution.Compat.Stack ( WithCallStack, CallStack, + annotateCallStackIO, withFrozenCallStack, withLexicalCallStack, callStack, @@ -11,6 +12,8 @@ module Distribution.Compat.Stack ( 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 index d3dd8368a3d..dafc5f151d9 100644 --- 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 index faf1be2d115..25e78aac82d 100644 --- 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 index 5b0f47cc486..528b8ad5dfa 100644 --- 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