wire tasty's option parser into the main program option parser

This makes bash completion work for git-annex test, and is
generally cleaner.

CmdLine/GitAnnex.hs

@@ -1,6 +1,6 @@
 {- git-annex main program
  -
- - Copyright 2010-2014 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2015 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -14,6 +14,7 @@ import CmdLine
 import Command
 import Utility.Env
 import Annex.Ssh
+import Types.Test
 
 import qualified Command.Help
 import qualified Command.Add
@@ -117,8 +118,8 @@ import qualified Command.TestRemote
 import System.Remote.Monitoring
 #endif
 
-cmds :: [Command]
-cmds = 
+cmds :: Parser TestOptions -> Maybe TestRunner -> [Command]
+cmds testoptparser testrunner = 
 	[ Command.Help.cmd
 	, Command.Add.cmd
 	, Command.Get.cmd
@@ -213,21 +214,23 @@ cmds =
 #endif
 	, Command.RemoteDaemon.cmd
 #endif
-	, Command.Test.cmd
+	, Command.Test.cmd testoptparser testrunner
 #ifdef WITH_TESTSUITE
 	, Command.FuzzTest.cmd
 	, Command.TestRemote.cmd
 #endif
 	]
 
-run :: [String] -> IO ()
-run args = do
+run :: Parser TestOptions -> Maybe TestRunner -> [String] -> IO ()
+run testoptparser testrunner args = do
 #ifdef WITH_EKG
 	_ <- forkServer "localhost" 4242
 #endif
 	go envmodes
   where
-	go [] = dispatch True args cmds gitAnnexGlobalOptions [] Git.CurrentRepo.get
+	go [] = dispatch True args 
+		(cmds testoptparser testrunner)
+		gitAnnexGlobalOptions [] Git.CurrentRepo.get
 		"git-annex"
 		"manage files with git, without checking their contents in"
 	go ((v, a):rest) = maybe (go rest) a =<< getEnv v

Command/Test.hs

@@ -1,6 +1,6 @@
 {- git-annex command
  -
- - Copyright 2013 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2015 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -10,31 +10,23 @@ module Command.Test where
 import Common
 import Command
 import Messages
+import Types.Test
 
-cmd :: Command
-cmd = noRepo (parseparams startIO) $ dontCheck repoExists $
-	command "test" SectionTesting
-		"run built-in test suite"
-		paramNothing (parseparams seek)
-  where
-	parseparams = withParams
+cmd :: Parser TestOptions -> Maybe TestRunner -> Command
+cmd optparser runner = noRepo (startIO runner <$$> const optparser) $
+	dontCheck repoExists $
+		command "test" SectionTesting
+			"run built-in test suite"
+			paramNothing (seek runner <$$> const optparser)
 
-seek :: CmdParams -> CommandSeek
-seek = withWords start
+seek :: Maybe TestRunner -> TestOptions -> CommandSeek
+seek runner o = commandAction $ start runner o
 
-{- We don't actually run the test suite here because of a dependency loop.
- - The main program notices when the command is test and runs it; this
- - function is never run if that works.
- -
- - However, if git-annex is built without the test suite, just print a
- - warning, and do not exit nonzero. This is so git-annex test can be run
- - in debian/rules despite some architectures not being able to build the
- - test suite.
- -}
-start :: [String] -> CommandStart
-start ps = do
-	liftIO $ startIO ps
+start :: Maybe TestRunner -> TestOptions -> CommandStart
+start runner o = do
+	liftIO $ startIO runner o
 	stop
 
-startIO :: CmdParams -> IO ()
-startIO _ = warningIO "git-annex was built without its test suite; not testing"
+startIO :: Maybe TestRunner -> TestOptions -> IO ()
+startIO Nothing _ = warningIO "git-annex was built without its test suite; not testing"
+startIO (Just runner) o = runner o

Test.hs

@@ -1,6 +1,6 @@
 {- git-annex test suite
  -
- - Copyright 2010-2013 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2015 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -9,7 +9,22 @@
 
 module Test where
 
+import Options.Applicative.Types
+
+#ifndef WITH_TESTSUITE
+
+import Options.Applicative (pure)
+
+optParser :: Parser ()
+optParser = pure ()
+
+runner :: Maybe (() -> IO ())
+runner = Nothing
+
+#else
+
 import Test.Tasty
+import Test.Tasty.Options
 import Test.Tasty.Runners
 import Test.Tasty.HUnit
 import Test.Tasty.QuickCheck
@@ -20,7 +35,6 @@ import qualified Text.JSON
 
 import Common
 
-import qualified Utility.SubTasty
 import qualified Utility.SafeCommand
 import qualified Annex
 import qualified Annex.UUID
@@ -81,18 +95,19 @@ import qualified Types.Crypto
 import qualified Utility.Gpg
 #endif
 
-main :: [String] -> IO ()
-main ps = do
-	opts <- Utility.SubTasty.parseOpts "test" ingredients tests ("test":ps)
-	case tryIngredients ingredients opts tests of
-		Nothing -> error "No tests found!?"
-		Just act -> ifM act
-			( exitSuccess
-			, do
-				putStrLn "  (This could be due to a bug in git-annex, or an incompatability"
-				putStrLn "   with utilities, such as git, installed on this system.)"
-				exitFailure
-			)
+optParser :: Parser OptionSet
+optParser = suiteOptionParser ingredients tests
+
+runner :: Maybe (OptionSet -> IO ())
+runner = Just $ \opts -> case tryIngredients ingredients opts tests of
+	Nothing -> error "No tests found!?"
+	Just act -> ifM act
+		( exitSuccess
+		, do
+			putStrLn "  (This could be due to a bug in git-annex, or an incompatability"
+			putStrLn "   with utilities, such as git, installed on this system.)"
+			exitFailure
+		)
 
 ingredients :: [Ingredient]
 ingredients =
@@ -1419,12 +1434,12 @@ test_addurl = intmpclonerepo $ do
 git_annex :: String -> [String] -> IO Bool
 git_annex command params = do
 	-- catch all errors, including normally fatal errors
-	r <- try run::IO (Either SomeException ())
+	r <- try run ::IO (Either SomeException ())
 	case r of
 		Right _ -> return True
 		Left _ -> return False
   where
-	run = GitAnnex.run (command:"-q":params)
+	run = GitAnnex.run optParser Nothing (command:"-q":params)
 
 {- Runs git-annex and returns its output. -}
 git_annex_output :: String -> [String] -> IO String
@@ -1762,3 +1777,5 @@ backendWORM = backend_ "WORM"
 
 backend_ :: String -> Types.Backend
 backend_ = Backend.lookupBackendName
+
+#endif

Types/Test.hs

@@ -0,0 +1,22 @@
+{- git-annex test data types.
+ -
+ - Copyright 2011-2015 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Types.Test where
+
+#ifdef WITH_TESTSUITE
+import Test.Tasty.Options
+#endif
+
+#ifdef WITH_TESTSUITE
+type TestOptions = OptionSet
+#else
+type TestOptions = ()
+#endif
+
+type TestRunner = TestOptions -> IO ()

Utility/SubTasty.hs

@@ -1,25 +0,0 @@
-{- Running tasty as a subcommand.
- -
- - Copyright 2015 Joey Hess <id@joeyh.name>
- -
- - License: BSD-2-clause
- -}
-
-module Utility.SubTasty where
-
-import Test.Tasty
-import Test.Tasty.Options
-import Test.Tasty.Runners
-import Options.Applicative
-
--- Uses tasty's option parser, modified to expect a subcommand.
-parseOpts :: String -> [Ingredient] -> TestTree -> [String] -> IO OptionSet
-parseOpts subcommand is ts = 
-	handleParseResult . execParserPure (prefs idm) pinfo
-  where
-	pinfo = info (helper <*> subpinfo) (fullDesc <> header desc)
-	subpinfo = subparser $ command subcommand $ 
-		suiteOptionParser is ts
-			`info`
-		progDesc desc
-	desc = "Builtin test suite"

git-annex.hs

@@ -13,9 +13,7 @@ import Network.Socket (withSocketsDo)
 
 import qualified CmdLine.GitAnnex
 import qualified CmdLine.GitAnnexShell
-#ifdef WITH_TESTSUITE
 import qualified Test
-#endif
 
 #ifdef mingw32_HOST_OS
 import Utility.UserInfo
@@ -37,14 +35,7 @@ main = withSocketsDo $ do
 #else
 			gitannex ps
 #endif
-	gitannex ps = 
-#ifdef WITH_TESTSUITE
-		case ps of
-			("test":ps') -> Test.main ps'
-			_ -> CmdLine.GitAnnex.run ps
-#else
-		CmdLine.GitAnnex.run ps
-#endif
+	gitannex = CmdLine.GitAnnex.run Test.optParser Test.runner
 	isshell n = takeFileName n == "git-annex-shell"
 
 #ifdef mingw32_HOST_OS