make test suite link in git-annex's commands and run directly

this way, test coverage works

GitAnnex.hs

@@ -0,0 +1,75 @@
+{- git-annex main program
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module GitAnnex where
+
+import System.Console.GetOpt
+
+import Command
+import Options
+
+import qualified Command.Add
+import qualified Command.Unannex
+import qualified Command.Drop
+import qualified Command.Move
+import qualified Command.Copy
+import qualified Command.Get
+import qualified Command.FromKey
+import qualified Command.DropKey
+import qualified Command.SetKey
+import qualified Command.Fix
+import qualified Command.Init
+import qualified Command.Fsck
+import qualified Command.Unused
+import qualified Command.DropUnused
+import qualified Command.Unlock
+import qualified Command.Lock
+import qualified Command.PreCommit
+import qualified Command.Find
+import qualified Command.Uninit
+import qualified Command.Trust
+import qualified Command.Untrust
+
+cmds :: [Command]
+cmds = concat
+	[ Command.Add.command
+	, Command.Get.command
+	, Command.Drop.command
+	, Command.Move.command
+	, Command.Copy.command
+	, Command.Unlock.command
+	, Command.Lock.command
+	, Command.Init.command
+	, Command.Unannex.command
+	, Command.Uninit.command
+	, Command.PreCommit.command
+	, Command.Trust.command
+	, Command.Untrust.command
+	, Command.FromKey.command
+	, Command.DropKey.command
+	, Command.SetKey.command
+	, Command.Fix.command
+	, Command.Fsck.command
+	, Command.Unused.command
+	, Command.DropUnused.command
+	, Command.Find.command
+	]
+
+options :: [Option]
+options = commonOptions ++
+	[ Option ['k'] ["key"] (ReqArg (storeOptString "key") paramKey)
+		"specify a key to use"
+	, Option ['t'] ["to"] (ReqArg (storeOptString "torepository") paramRemote)
+		"specify to where to transfer content"
+	, Option ['f'] ["from"] (ReqArg (storeOptString "fromrepository") paramRemote)
+		"specify from where to transfer content"
+	, Option ['x'] ["exclude"] (ReqArg (storeOptString "exclude") paramGlob)
+		"skip files matching the glob pattern"
+	]
+
+header :: String
+header = "Usage: git-annex command [option ..]"

debian/changelog

@@ -8,7 +8,7 @@ git-annex (0.16) UNRELEASED; urgency=low
     significant problem, since the remote *did* record that it had the file.
   * Also, add a general guard to detect attempts to record information
     about repositories with missing UUIDs.
-  * Test suite improvements.
+  * Test suite improvements. Current top-level test coverage: 43%
 
  -- Joey Hess <joeyh@debian.org>  Tue, 04 Jan 2011 17:33:42 -0400
 

git-annex.hs

@@ -6,74 +6,10 @@
  -}
 
 import System.Environment
-import System.Console.GetOpt
 
 import qualified GitRepo as Git
 import CmdLine
-import Command
+import GitAnnex
-import Options
-
-import qualified Command.Add
-import qualified Command.Unannex
-import qualified Command.Drop
-import qualified Command.Move
-import qualified Command.Copy
-import qualified Command.Get
-import qualified Command.FromKey
-import qualified Command.DropKey
-import qualified Command.SetKey
-import qualified Command.Fix
-import qualified Command.Init
-import qualified Command.Fsck
-import qualified Command.Unused
-import qualified Command.DropUnused
-import qualified Command.Unlock
-import qualified Command.Lock
-import qualified Command.PreCommit
-import qualified Command.Find
-import qualified Command.Uninit
-import qualified Command.Trust
-import qualified Command.Untrust
-
-cmds :: [Command]
-cmds = concat
-	[ Command.Add.command
-	, Command.Get.command
-	, Command.Drop.command
-	, Command.Move.command
-	, Command.Copy.command
-	, Command.Unlock.command
-	, Command.Lock.command
-	, Command.Init.command
-	, Command.Unannex.command
-	, Command.Uninit.command
-	, Command.PreCommit.command
-	, Command.Trust.command
-	, Command.Untrust.command
-	, Command.FromKey.command
-	, Command.DropKey.command
-	, Command.SetKey.command
-	, Command.Fix.command
-	, Command.Fsck.command
-	, Command.Unused.command
-	, Command.DropUnused.command
-	, Command.Find.command
-	]
-
-options :: [Option]
-options = commonOptions ++
-	[ Option ['k'] ["key"] (ReqArg (storeOptString "key") paramKey)
-		"specify a key to use"
-	, Option ['t'] ["to"] (ReqArg (storeOptString "torepository") paramRemote)
-		"specify to where to transfer content"
-	, Option ['f'] ["from"] (ReqArg (storeOptString "fromrepository") paramRemote)
-		"specify from where to transfer content"
-	, Option ['x'] ["exclude"] (ReqArg (storeOptString "exclude") paramGlob)
-		"skip files matching the glob pattern"
-	]
-
-header :: String
-header = "Usage: git-annex command [option ..]"
 
 main :: IO ()
 main = do

test.hs

@@ -10,35 +10,30 @@ import Test.HUnit.Tools
 import System.Directory
 import System.Posix.Directory (changeWorkingDirectory)
 import System.Posix.Files
-import System.Posix.Env
 import IO (bracket_, bracket)
 import Control.Monad (unless, when)
 import Data.List
 import System.IO.Error
 
 import qualified GitRepo as Git
-import Locations
+import qualified Locations
-import Utility
+import qualified Utility
-import TypeInternals
+import qualified TypeInternals
+import qualified GitAnnex
+import qualified CmdLine
 
 main :: IO (Counts, Int)
-main = do
+main = runVerboseTests $ TestList [quickchecks, toplevels]
-	-- Add current directory to the from of PATH, so git-annex etc will
-	-- be used, no matter where it is run from.
-	cwd <- getCurrentDirectory
-	p <- getEnvDefault "PATH" ""
-	setEnv "PATH" (cwd++":"++p) True
-	runVerboseTests $ TestList [quickchecks, toplevels]
 
 quickchecks :: Test
 quickchecks = TestLabel "quickchecks" $ TestList
 	[ qctest "prop_idempotent_deencode" Git.prop_idempotent_deencode
-	, qctest "prop_idempotent_fileKey" prop_idempotent_fileKey
+	, qctest "prop_idempotent_fileKey" Locations.prop_idempotent_fileKey
-	, qctest "prop_idempotent_key_read_show" prop_idempotent_key_read_show
+	, qctest "prop_idempotent_key_read_show" TypeInternals.prop_idempotent_key_read_show
-	, qctest "prop_idempotent_shellEscape" prop_idempotent_shellEscape
+	, qctest "prop_idempotent_shellEscape" Utility.prop_idempotent_shellEscape
-	, qctest "prop_idempotent_shellEscape_multiword" prop_idempotent_shellEscape_multiword
+	, qctest "prop_idempotent_shellEscape_multiword" Utility.prop_idempotent_shellEscape_multiword
-	, qctest "prop_parentDir_basics" prop_parentDir_basics
+	, qctest "prop_parentDir_basics" Utility.prop_parentDir_basics
-	, qctest "prop_relPathDirToDir_basics" prop_relPathDirToDir_basics
+	, qctest "prop_relPathDirToDir_basics" Utility.prop_relPathDirToDir_basics
 	]
 
 toplevels :: Test
@@ -79,7 +74,14 @@ test_add = TestLabel "git-annex add" $ TestCase $ inannex $ do
 		content = "foo file content"
 
 git_annex :: String -> [String] -> IO Bool
-git_annex command params = boolSystem "git-annex" (command:params)
+git_annex command params = do
+	gitrepo <- Git.repoFromCwd
+	r <- try $
+		CmdLine.dispatch gitrepo (command:params)
+			GitAnnex.cmds GitAnnex.options GitAnnex.header
+	case r of
+		Right _ -> return True
+		Left _ -> return False
 
 inannex :: Assertion -> Assertion
 inannex a = ingitrepo $ do
@@ -103,7 +105,7 @@ withgitrepo = bracket setup cleanup
 		setup = do
 			cleanup True
 			createDirectory tmpdir
-			ok <- boolSystem "git" ["init", "-q", repodir]
+			ok <- Utility.boolSystem "git" ["init", "-q", repodir]
 			unless ok $
 				assertFailure "git init failed"
 			return $ Git.repoFromPath repodir
@@ -113,5 +115,5 @@ withgitrepo = bracket setup cleanup
 				-- git-annex prevents annexed file content
 				-- from being removed with permissions
 				-- bits; undo
-				_ <- boolSystem "chmod" ["+rw", "-R", tmpdir]
+				_ <- Utility.boolSystem "chmod" ["+rw", "-R", tmpdir]
 				removeDirectoryRecursive tmpdir