summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2015-07-13 13:19:20 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2015-07-13 13:20:10 -0400
commit52cfabcd567a3b15c8217edce752f3a3c59ca5ce (patch)
treef0512188b4e56640fcceeec0dddb9c754ed23783
parent8e9ddfe41e73662be5c7fd0ebc6432a52b1dd227 (diff)
wire tasty's option parser into the main program option parser
This makes bash completion work for git-annex test, and is generally cleaner.
-rw-r--r--CmdLine/GitAnnex.hs17
-rw-r--r--Command/Test.hs40
-rw-r--r--Test.hs49
-rw-r--r--Types/Test.hs22
-rw-r--r--Utility/SubTasty.hs25
-rw-r--r--git-annex.hs11
6 files changed, 82 insertions, 82 deletions
diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs
index 9c60956f6..f585bff3e 100644
--- a/CmdLine/GitAnnex.hs
+++ b/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
diff --git a/Command/Test.hs b/Command/Test.hs
index 57a9b16d3..35d6e1504 100644
--- a/Command/Test.hs
+++ b/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
diff --git a/Test.hs b/Test.hs
index 762854f1f..46bb236a6 100644
--- a/Test.hs
+++ b/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
diff --git a/Types/Test.hs b/Types/Test.hs
new file mode 100644
index 000000000..35c4c3c23
--- /dev/null
+++ b/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 ()
diff --git a/Utility/SubTasty.hs b/Utility/SubTasty.hs
deleted file mode 100644
index 5164f9d1b..000000000
--- a/Utility/SubTasty.hs
+++ /dev/null
@@ -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"
diff --git a/git-annex.hs b/git-annex.hs
index 17ce807af..ca8eecd2a 100644
--- a/git-annex.hs
+++ b/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