From b9c249d46e582bf52b771368cfe9d8d455c11f9f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 14 Feb 2016 15:02:42 -0400 Subject: Work around problem with concurrent-output when in a non-unicode locale by avoiding use of it in such a locale. Instead -J will behave as if it was built without concurrent-output support in this situation. Ie, it will be mostly quiet, except when there's an error. Note that it's not a problem for a filename to contain invalid utf-8 when in a utf-8 locale. That is handled ok by concurrent-output. It's only displaying unicode characters in a non-unicode locale that doesn't work. --- Messages/Concurrent.hs | 73 +++++++++++++++++++++++++++++++++----------------- Messages/Internal.hs | 4 +-- Messages/Progress.hs | 24 ++++++++--------- 3 files changed, 63 insertions(+), 38 deletions(-) (limited to 'Messages') diff --git a/Messages/Concurrent.hs b/Messages/Concurrent.hs index a4710e310..ee81109f1 100644 --- a/Messages/Concurrent.hs +++ b/Messages/Concurrent.hs @@ -1,13 +1,12 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - {- git-annex output messages, including concurrent output to display regions - - - Copyright 2010-2015 Joey Hess + - Copyright 2010-2016 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Messages.Concurrent where @@ -20,6 +19,7 @@ import qualified System.Console.Concurrent as Console import qualified System.Console.Regions as Regions import Control.Concurrent.STM import qualified Data.Text as T +import GHC.IO.Encoding #endif {- Outputs a message in a concurrency safe way. @@ -29,9 +29,14 @@ import qualified Data.Text as T - When built without concurrent-output support, the fallback action is run - instead. -} -concurrentMessage :: Bool -> String -> Annex () -> Annex () +concurrentMessage :: OutputType -> Bool -> String -> Annex () -> Annex () +#ifdef WITH_CONCURRENTOUTPUT +concurrentMessage o iserror msg fallback + | concurrentOutputEnabled o = + go =<< consoleRegion <$> Annex.getState Annex.output +#endif + | otherwise = fallback #ifdef WITH_CONCURRENTOUTPUT -concurrentMessage iserror msg _ = go =<< consoleRegion <$> Annex.getState Annex.output where go Nothing | iserror = liftIO $ Console.errorConcurrent msg @@ -48,9 +53,6 @@ concurrentMessage iserror msg _ = go =<< consoleRegion <$> Annex.getState Annex. rl <- takeTMVar Regions.regionList putTMVar Regions.regionList (if r `elem` rl then rl else r:rl) - -#else -concurrentMessage _ _ fallback = fallback #endif {- Runs an action in its own dedicated region of the console. @@ -62,21 +64,25 @@ concurrentMessage _ _ fallback = fallback - When not at a console, a region is not displayed until the action is - complete. -} -inOwnConsoleRegion :: Annex a -> Annex a +inOwnConsoleRegion :: OutputType -> Annex a -> Annex a +inOwnConsoleRegion o a +#ifdef WITH_CONCURRENTOUTPUT + | concurrentOutputEnabled o = do + r <- mkregion + setregion (Just r) + eret <- tryNonAsync a `onException` rmregion r + case eret of + Left e -> do + -- Add error message to region before it closes. + concurrentMessage o True (show e) noop + rmregion r + throwM e + Right ret -> do + rmregion r + return ret +#endif + | otherwise = a #ifdef WITH_CONCURRENTOUTPUT -inOwnConsoleRegion a = do - r <- mkregion - setregion (Just r) - eret <- tryNonAsync a `onException` rmregion r - case eret of - Left e -> do - -- Add error message to region before it closes. - concurrentMessage True (show e) noop - rmregion r - throwM e - Right ret -> do - rmregion r - return ret where -- The region is allocated here, but not displayed until -- a message is added to it. This avoids unnecessary screen @@ -94,8 +100,6 @@ inOwnConsoleRegion a = do unless (T.null t) $ Console.bufferOutputSTM h t Regions.closeConsoleRegion r -#else -inOwnConsoleRegion = id #endif {- The progress region is displayed inline with the current console region. -} @@ -108,3 +112,24 @@ withProgressRegion a = do instance Regions.LiftRegion Annex where liftRegion = liftIO . atomically #endif + +{- The concurrent-output library uses Text, which bypasses the normal use + - of the fileSystemEncoding to roundtrip invalid characters, when in a + - non-unicode locale. Work around that problem by avoiding using + - concurrent output when not in a unicode locale. -} +concurrentOutputSupported :: IO Bool +#ifdef WITH_CONCURRENTOUTPUT +#ifndef mingw32_HOST_OS +concurrentOutputSupported = do + enc <- getLocaleEncoding + return ("UTF" `isInfixOf` textEncodingName enc) +#else +concurrentOutputSupported = return True -- Windows is always unicode +#endif +#else +concurrentOutputSupported = return False +#endif + +concurrentOutputEnabled :: OutputType -> Bool +concurrentOutputEnabled (ConcurrentOutput _ b) = b +concurrentOutputEnabled _ = False diff --git a/Messages/Internal.hs b/Messages/Internal.hs index fcbbe10b4..9b9edccc5 100644 --- a/Messages/Internal.hs +++ b/Messages/Internal.hs @@ -21,13 +21,13 @@ outputMessage json s = withOutputType go go NormalOutput = liftIO $ flushed $ putStr s go QuietOutput = q - go (ConcurrentOutput _) = concurrentMessage False s q + go o@(ConcurrentOutput {}) = concurrentMessage o False s q go JSONOutput = liftIO $ flushed json outputError :: String -> Annex () outputError s = withOutputType go where - go (ConcurrentOutput _) = concurrentMessage True s (go NormalOutput) + go o@(ConcurrentOutput {}) = concurrentMessage o True s (go NormalOutput) go _ = liftIO $ do hFlush stdout hPutStr stderr s diff --git a/Messages/Progress.hs b/Messages/Progress.hs index 25d803b1b..6bbf43f4c 100644 --- a/Messages/Progress.hs +++ b/Messages/Progress.hs @@ -46,16 +46,16 @@ metered combinemeterupdate key a = case keySize key of liftIO $ clearMeter stdout meter return r #if WITH_CONCURRENTOUTPUT - go size (ConcurrentOutput _) = withProgressRegion $ \r -> do - (progress, meter) <- mkmeter size - a $ \n -> liftIO $ do - setP progress $ fromBytesProcessed n - s <- renderMeter meter - Regions.setConsoleRegion r ("\n" ++ s) - maybe noop (\m -> m n) combinemeterupdate -#else - go _ (ConcurrentOutput _) = nometer + go size o@(ConcurrentOutput {}) + | concurrentOutputEnabled o = withProgressRegion $ \r -> do + (progress, meter) <- mkmeter size + a $ \n -> liftIO $ do + setP progress $ fromBytesProcessed n + s <- renderMeter meter + Regions.setConsoleRegion r ("\n" ++ s) + maybe noop (\m -> m n) combinemeterupdate #endif + | otherwise = nometer mkmeter size = do progress <- liftIO $ newProgress "" size @@ -69,14 +69,14 @@ metered combinemeterupdate key a = case keySize key of concurrentMetered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a concurrentMetered combinemeterupdate key a = withOutputType go where - go (ConcurrentOutput _) = metered combinemeterupdate key a + go (ConcurrentOutput {}) = metered combinemeterupdate key a go _ = a (fromMaybe nullMeterUpdate combinemeterupdate) {- Poll file size to display meter, but only for concurrent output. -} concurrentMeteredFile :: FilePath -> Maybe MeterUpdate -> Key -> Annex a -> Annex a concurrentMeteredFile file combinemeterupdate key a = withOutputType go where - go (ConcurrentOutput _) = metered combinemeterupdate key $ \p -> + go (ConcurrentOutput {}) = metered combinemeterupdate key $ \p -> watchFileSize file p a go _ = a @@ -120,6 +120,6 @@ mkStderrEmitter :: Annex (String -> IO ()) mkStderrEmitter = withOutputType go where #ifdef WITH_CONCURRENTOUTPUT - go (ConcurrentOutput _) = return Console.errorConcurrent + go o | concurrentOutputEnabled o = return Console.errorConcurrent #endif go _ = return (hPutStrLn stderr) -- cgit v1.2.3