fuzz improvements

Command/FuzzTest.hs

@@ -178,66 +178,84 @@ runFuzzAction (FuzzMoveDir (FuzzDir src) (FuzzDir dest)) = liftIO $
 runFuzzAction (FuzzPause d) = liftIO $ randomDelay d
 
 genFuzzAction :: Annex FuzzAction
-genFuzzAction = liftIO $ do
+genFuzzAction = do
-	tmpl <- Prelude.head <$> sample' (arbitrary :: Gen FuzzAction)
+	tmpl <- liftIO $ Prelude.head <$> sample' (arbitrary :: Gen FuzzAction)
 	-- Fix up template action to make sense in the current repo tree.
 	case tmpl of
-		FuzzAdd _ -> FuzzAdd <$> newFile
+		FuzzAdd _ -> do
-		FuzzDelete _ -> FuzzDelete <$> existingFile ""
+			f <- liftIO newFile
-		FuzzMove _ _ -> FuzzMove <$> existingFile "" <*> newFile
+			maybe genFuzzAction (return . FuzzAdd) f
+		FuzzDelete _ -> do
+			f <- liftIO $ existingFile 0 ""
+			maybe genFuzzAction (return . FuzzDelete) f
+		FuzzMove _ _ -> do
+			src <- liftIO $ existingFile 0 ""
+			dest <- liftIO newFile
+			case (src, dest) of
+				(Just s, Just d) -> return $ FuzzMove s d
+				_ -> genFuzzAction
 		FuzzMoveDir _ _ -> do
-			d <- existingDir
+			md <- liftIO existingDir
-			newd <- newDir (parentDir $ toFilePath d)
+			case md of
-			return $ FuzzMoveDir d newd
+				Nothing -> genFuzzAction
-		FuzzDeleteDir _ -> FuzzDeleteDir <$> existingDir
+				Just d -> do
-		FuzzModify _ -> FuzzModify <$> existingFile ""
+					newd <- liftIO $ newDir (parentDir $ toFilePath d)
+					maybe genFuzzAction (return . FuzzMoveDir d) newd
+		FuzzDeleteDir _ -> do
+			d <- liftIO existingDir
+			maybe genFuzzAction (return . FuzzDeleteDir) d
+		FuzzModify _ -> do
+			f <- liftIO $ existingFile 0 ""
+			maybe genFuzzAction (return . FuzzModify) f
 		FuzzPause _ -> return tmpl
 
-existingFile :: FilePath -> IO FuzzFile
+existingFile :: Int -> FilePath -> IO (Maybe FuzzFile)
-existingFile top = do
+existingFile 0 _ = return Nothing
-	dir <- toFilePath <$> existingDir
+existingFile n top = maybe (return Nothing) (go . toFilePath) =<< existingDir
+  where
+  	go dir = do
 		contents <- catchDefaultIO [] (getDirectoryContents dir)
 		let files = filter isFuzzFile contents
 		if null files
 			then do
 				let dirs = filter isFuzzDir contents
 				if null dirs
-				then return $ FuzzFile ""
+					then return Nothing
 					else do
 						n <- getStdRandom $ randomR (0, length dirs - 1)
-					existingFile (top </> dirs !! n)
+						existingFile (n - 1) (top </> dirs !! n)
 			else do
 				n <- getStdRandom $ randomR (0, length files - 1)
-			return $ FuzzFile $ top </> dir </> files !! n
+				return $ Just $ FuzzFile $ top </> dir </> files !! n
 	
-existingDir :: IO FuzzDir
+existingDir :: IO (Maybe FuzzDir)
 existingDir = do
 	dirs <- filter isFuzzDir <$> getDirectoryContents "."
 	if null dirs
-		then return $ FuzzDir ""
+		then return Nothing
 		else do
 			n <- getStdRandom $ randomR (0, length dirs)
-			return $ FuzzDir $ ("." : dirs) !! n
+			return $ Just $ FuzzDir $ ("." : dirs) !! n
 
-newFile :: IO FuzzFile
+newFile :: IO (Maybe FuzzFile)
 newFile = go (100 :: Int)
   where
-  	go 0 = return $ FuzzFile ""
+  	go 0 = return Nothing
 	go n = do
 		f <- genFuzzFile
 		ifM (doesnotexist (toFilePath f))
-			( return f
+			( return $ Just f
 			, go (n - 1)
 			)
 
-newDir :: FilePath -> IO FuzzDir
+newDir :: FilePath -> IO (Maybe FuzzDir)
 newDir parent = go (100 :: Int)
   where
-  	go 0 = return $ FuzzDir ""
+  	go 0 = return Nothing
 	go n = do
 		(FuzzDir d) <- genFuzzDir
 		ifM (doesnotexist (parent </> d))
-			( return $ FuzzDir d
+			( return $ Just $ FuzzDir d
 			, go (n - 1)
 			)