generalize to allow running in Assistant monad
This commit is contained in:
parent
7a9b618d5d
commit
4efecaebd6
2 changed files with 31 additions and 9 deletions
|
@ -98,10 +98,14 @@ inOwnConsoleRegion s a
|
||||||
Regions.closeConsoleRegion r
|
Regions.closeConsoleRegion r
|
||||||
|
|
||||||
{- The progress region is displayed inline with the current console region. -}
|
{- The progress region is displayed inline with the current console region. -}
|
||||||
withProgressRegion :: (Regions.ConsoleRegion -> Annex a) -> Annex a
|
withProgressRegion
|
||||||
withProgressRegion a = do
|
:: (MonadIO m, MonadMask m)
|
||||||
parent <- consoleRegion <$> Annex.getState Annex.output
|
=> MessageState
|
||||||
|
-> (Regions.ConsoleRegion -> m a) -> m a
|
||||||
|
withProgressRegion st a =
|
||||||
Regions.withConsoleRegion (maybe Regions.Linear Regions.InLine parent) a
|
Regions.withConsoleRegion (maybe Regions.Linear Regions.InLine parent) a
|
||||||
|
where
|
||||||
|
parent = consoleRegion st
|
||||||
|
|
||||||
instance Regions.LiftRegion Annex where
|
instance Regions.LiftRegion Annex where
|
||||||
liftRegion = liftIO . atomically
|
liftRegion = liftIO . atomically
|
||||||
|
|
|
@ -24,6 +24,7 @@ import Messages.Internal
|
||||||
|
|
||||||
import qualified System.Console.Regions as Regions
|
import qualified System.Console.Regions as Regions
|
||||||
import qualified System.Console.Concurrent as Console
|
import qualified System.Console.Concurrent as Console
|
||||||
|
import Control.Monad.IO.Class (MonadIO)
|
||||||
|
|
||||||
{- Class of things from which a size can be gotten to display a progress
|
{- Class of things from which a size can be gotten to display a progress
|
||||||
- meter. -}
|
- meter. -}
|
||||||
|
@ -64,13 +65,30 @@ instance MeterSize KeySizer where
|
||||||
{- Shows a progress meter while performing an action.
|
{- Shows a progress meter while performing an action.
|
||||||
- The action is passed the meter and a callback to use to update the meter.
|
- The action is passed the meter and a callback to use to update the meter.
|
||||||
--}
|
--}
|
||||||
metered :: MeterSize sizer => Maybe MeterUpdate -> sizer -> (Meter -> MeterUpdate -> Annex a) -> Annex a
|
metered
|
||||||
metered othermeter sizer a = withMessageState $ \st ->
|
:: MeterSize sizer
|
||||||
flip go st =<< getMeterSize sizer
|
=> Maybe MeterUpdate
|
||||||
|
-> sizer
|
||||||
|
-> (Meter -> MeterUpdate -> Annex a)
|
||||||
|
-> Annex a
|
||||||
|
metered othermeter sizer a = withMessageState $ \st -> do
|
||||||
|
sz <- getMeterSize sizer
|
||||||
|
metered' st othermeter sz showOutput a
|
||||||
|
|
||||||
|
metered'
|
||||||
|
:: (Monad m, MonadIO m, MonadMask m)
|
||||||
|
=> MessageState
|
||||||
|
-> Maybe MeterUpdate
|
||||||
|
-> Maybe FileSize
|
||||||
|
-> m ()
|
||||||
|
-- ^ this should run showOutput
|
||||||
|
-> (Meter -> MeterUpdate -> m a)
|
||||||
|
-> m a
|
||||||
|
metered' st othermeter size showoutput a = go size st
|
||||||
where
|
where
|
||||||
go _ (MessageState { outputType = QuietOutput }) = nometer
|
go _ (MessageState { outputType = QuietOutput }) = nometer
|
||||||
go msize (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do
|
go msize (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do
|
||||||
showOutput
|
showoutput
|
||||||
meter <- liftIO $ mkMeter msize $
|
meter <- liftIO $ mkMeter msize $
|
||||||
displayMeterHandle stdout bandwidthMeter
|
displayMeterHandle stdout bandwidthMeter
|
||||||
m <- liftIO $ rateLimitMeterUpdate consoleratelimit meter $
|
m <- liftIO $ rateLimitMeterUpdate consoleratelimit meter $
|
||||||
|
@ -79,7 +97,7 @@ metered othermeter sizer a = withMessageState $ \st ->
|
||||||
liftIO $ clearMeterHandle meter stdout
|
liftIO $ clearMeterHandle meter stdout
|
||||||
return r
|
return r
|
||||||
go msize (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) =
|
go msize (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) =
|
||||||
withProgressRegion $ \r -> do
|
withProgressRegion st $ \r -> do
|
||||||
meter <- liftIO $ mkMeter msize $ \_ msize' old new ->
|
meter <- liftIO $ mkMeter msize $ \_ msize' old new ->
|
||||||
let s = bandwidthMeter msize' old new
|
let s = bandwidthMeter msize' old new
|
||||||
in Regions.setConsoleRegion r ('\n' : s)
|
in Regions.setConsoleRegion r ('\n' : s)
|
||||||
|
@ -88,7 +106,7 @@ metered othermeter sizer a = withMessageState $ \st ->
|
||||||
a meter (combinemeter m)
|
a meter (combinemeter m)
|
||||||
go msize (MessageState { outputType = JSONOutput jsonoptions })
|
go msize (MessageState { outputType = JSONOutput jsonoptions })
|
||||||
| jsonProgress jsonoptions = do
|
| jsonProgress jsonoptions = do
|
||||||
buf <- withMessageState $ return . jsonBuffer
|
let buf = jsonBuffer st
|
||||||
meter <- liftIO $ mkMeter msize $ \_ msize' _old new ->
|
meter <- liftIO $ mkMeter msize $ \_ msize' _old new ->
|
||||||
JSON.progress buf msize' (meterBytesProcessed new)
|
JSON.progress buf msize' (meterBytesProcessed new)
|
||||||
m <- liftIO $ rateLimitMeterUpdate jsonratelimit meter $
|
m <- liftIO $ rateLimitMeterUpdate jsonratelimit meter $
|
||||||
|
|
Loading…
Reference in a new issue