fix --json-progress --json to be same as --json --json-progress

Fix behavior of --json-progress followed by --json, in which
the latter option disabled the former.

This commit was supported by the NSF-funded DataLad project.

5 files changed, 35 insertions, 12 deletions

diff --git a/Annex.hs b/Annex.hs
index 4ab700332..7b4bb706c 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -275,7 +275,8 @@ addCleanup k a = changeState $ \s ->
 {- Sets the type of output to emit. -}
 setOutput :: OutputType -> Annex ()
 setOutput o = changeState $ \s ->
-	s { output = (output s) { outputType = o } }
+	let m = output s
+	in s { output = m { outputType = adjustOutputType (outputType m) o } }
 
 {- Checks if a flag was set. -}
 getFlag :: String -> Annex Bool
diff --git a/CHANGELOG b/CHANGELOG
index 7d75e70d1..204004a60 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -17,6 +17,8 @@ git-annex (6.20180113) UNRELEASED; urgency=medium
     hopefully hackage finally recognises that OS.
   * Split Test.hs and avoid optimising it much, to need less memory to
     compile.
+  * Fix behavior of --json-progress followed by --json, in which
+    the latter option disabled the former.
 
  -- Joey Hess <id@joeyh.name>  Wed, 24 Jan 2018 20:42:55 -0400
 
diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs
index d762f6a00..51c55b056 100644
--- a/CmdLine/GitAnnex/Options.hs
+++ b/CmdLine/GitAnnex/Options.hs
@@ -295,18 +295,26 @@ combiningOptions =
 	shortopt o h = globalFlag (Limit.addToken [o]) ( short o <> help h <> hidden )
 
 jsonOption :: GlobalOption
-jsonOption = globalFlag (Annex.setOutput (JSONOutput False))
+jsonOption = globalFlag (Annex.setOutput (JSONOutput jsonoptions))
 	( long "json" <> short 'j'
 	<> help "enable JSON output"
 	<> hidden
 	)
+  where
+	jsonoptions = JSONOptions
+		{ jsonProgress = False
+		}
 
 jsonProgressOption :: GlobalOption
-jsonProgressOption = globalFlag (Annex.setOutput (JSONOutput True))
+jsonProgressOption = globalFlag (Annex.setOutput (JSONOutput jsonoptions))
 	( long "json-progress"
 	<> help "include progress in JSON output"
 	<> hidden
 	)
+  where
+	jsonoptions = JSONOptions
+		{ jsonProgress = True
+		}
 
 -- Note that a command that adds this option should wrap its seek
 -- action in `allowConcurrentOutput`.
diff --git a/Messages/Progress.hs b/Messages/Progress.hs
index 61486d78d..cb924eeac 100644
--- a/Messages/Progress.hs
+++ b/Messages/Progress.hs
@@ -55,12 +55,13 @@ metered othermeter key getsrcfile a = withMessageState $ \st ->
 #else
 		nometer
 #endif
-	go _ (MessageState { outputType = JSONOutput False }) = nometer
-	go msize (MessageState { outputType = JSONOutput True }) = do
-		buf <- withMessageState $ return . jsonBuffer
-		m <- liftIO $ rateLimitMeterUpdate 0.1 msize $
-			JSON.progress buf msize
-		a (combinemeter m)
+	go msize (MessageState { outputType = JSONOutput jsonoptions })
+		| jsonProgress jsonoptions = do
+			buf <- withMessageState $ return . jsonBuffer
+			m <- liftIO $ rateLimitMeterUpdate 0.1 msize $
+				JSON.progress buf msize
+			a (combinemeter m)
+		| otherwise = nometer
 
 	nometer = a $ combinemeter (const noop)
 
@@ -96,7 +97,7 @@ meteredFile file combinemeterupdate key a =
 
 needOutputMeter :: MessageState -> Bool
 needOutputMeter s = case outputType s of
-	JSONOutput True -> True
+	JSONOutput jsonoptions -> jsonProgress jsonoptions
 	NormalOutput | concurrentOutputEnabled s -> True
 	_ -> False
 
diff --git a/Types/Messages.hs b/Types/Messages.hs
index 551531349..f259f3200 100644
--- a/Types/Messages.hs
+++ b/Types/Messages.hs
@@ -1,6 +1,6 @@
 {- git-annex Messages data types
  - 
- - Copyright 2012-2017 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2018 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -16,9 +16,20 @@ import Control.Concurrent
 import System.Console.Regions (ConsoleRegion)
 #endif
 
-data OutputType = NormalOutput | QuietOutput | JSONOutput Bool
+data OutputType = NormalOutput | QuietOutput | JSONOutput JSONOptions
 	deriving (Show)
 
+data JSONOptions = JSONOptions
+	{ jsonProgress :: Bool
+	}
+	deriving (Show)
+
+adjustOutputType :: OutputType -> OutputType -> OutputType
+adjustOutputType (JSONOutput old) (JSONOutput new) = JSONOutput $ JSONOptions
+	{ jsonProgress = jsonProgress old || jsonProgress new
+	}
+adjustOutputType _old new = new
+
 data SideActionBlock = NoBlock | StartBlock | InBlock
 	deriving (Eq)