blob: 41153d067f8bffb1109ec97f8d905aac1e6fce9d (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
{- git-annex output messages, including concurrent output to display regions
-
- Copyright 2010-2016 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Messages.Concurrent where
import Annex
import Types.Messages
#ifdef WITH_CONCURRENTOUTPUT
import Common
import qualified System.Console.Concurrent as Console
import qualified System.Console.Regions as Regions
import Control.Concurrent.STM
import qualified Data.Text as T
#ifndef mingw32_HOST_OS
import GHC.IO.Encoding
#endif
#endif
{- Outputs a message in a concurrency safe way.
-
- The message may be an error message, in which case it goes to stderr.
-
- When built without concurrent-output support, the fallback action is run
- instead.
-}
concurrentMessage :: MessageState -> Bool -> String -> Annex () -> Annex ()
#ifdef WITH_CONCURRENTOUTPUT
concurrentMessage s iserror msg fallback
| concurrentOutputEnabled s =
go =<< consoleRegion <$> Annex.getState Annex.output
#else
concurrentMessage _s _iserror _msg fallback
#endif
| otherwise = fallback
#ifdef WITH_CONCURRENTOUTPUT
where
go Nothing
| iserror = liftIO $ Console.errorConcurrent msg
| otherwise = liftIO $ Console.outputConcurrent msg
go (Just r) = do
-- Can't display the error to stdout while
-- console regions are in use, so set the errflag
-- to get it to display to stderr later.
when iserror $ do
Annex.changeState $ \st ->
st { Annex.output = (Annex.output st) { consoleRegionErrFlag = True } }
liftIO $ atomically $ do
Regions.appendConsoleRegion r msg
rl <- takeTMVar Regions.regionList
putTMVar Regions.regionList
(if r `elem` rl then rl else r:rl)
#endif
{- Runs an action in its own dedicated region of the console.
-
- The region is closed at the end or on exception, and at that point
- the value of the region is displayed in the scrolling area above
- any other active regions.
-
- When not at a console, a region is not displayed until the action is
- complete.
-}
inOwnConsoleRegion :: MessageState -> Annex a -> Annex a
#ifdef WITH_CONCURRENTOUTPUT
inOwnConsoleRegion s a
| concurrentOutputEnabled s = 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 s True (show e) noop
rmregion r
throwM e
Right ret -> do
rmregion r
return ret
#else
inOwnConsoleRegion _s a
#endif
| otherwise = a
#ifdef WITH_CONCURRENTOUTPUT
where
-- The region is allocated here, but not displayed until
-- a message is added to it. This avoids unnecessary screen
-- updates when a region does not turn out to need to be used.
mkregion = Regions.newConsoleRegion Regions.Linear ""
setregion r = Annex.changeState $ \st -> st
{ Annex.output = (Annex.output st) { consoleRegion = r } }
rmregion r = do
errflag <- consoleRegionErrFlag <$> Annex.getState Annex.output
let h = if errflag then Console.StdErr else Console.StdOut
Annex.changeState $ \st -> st
{ Annex.output = (Annex.output st) { consoleRegionErrFlag = False } }
setregion Nothing
liftIO $ atomically $ do
t <- Regions.getConsoleRegion r
unless (T.null t) $
Console.bufferOutputSTM h t
Regions.closeConsoleRegion r
#endif
{- The progress region is displayed inline with the current console region. -}
#ifdef WITH_CONCURRENTOUTPUT
withProgressRegion :: (Regions.ConsoleRegion -> Annex a) -> Annex a
withProgressRegion a = do
parent <- consoleRegion <$> Annex.getState Annex.output
Regions.withConsoleRegion (maybe Regions.Linear Regions.InLine parent) a
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
|
