fuzz tester: avoid deleting entire repository (had to happen eventually, right?)

Command/FuzzTest.hs

@@ -211,31 +211,37 @@ genFuzzAction = do
 
 existingFile :: Int -> FilePath -> IO (Maybe FuzzFile)
 existingFile 0 _ = return Nothing
-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 Nothing
-					else do
-						i <- getStdRandom $ randomR (0, length dirs - 1)
-						existingFile (n - 1) (top </> dirs !! i)
-			else do
-				i <- getStdRandom $ randomR (0, length files - 1)
-				return $ Just $ FuzzFile $ top </> dir </> files !! i
+existingFile n top = do
+	dir <- existingDirIncludingTop
+	contents <- catchDefaultIO [] (getDirectoryContents dir)
+	let files = filter isFuzzFile contents
+	if null files
+		then do
+			let dirs = filter isFuzzDir contents
+			if null dirs
+				then return Nothing
+				else do
+					i <- getStdRandom $ randomR (0, length dirs - 1)
+					existingFile (n - 1) (top </> dirs !! i)
+		else do
+			i <- getStdRandom $ randomR (0, length files - 1)
+			return $ Just $ FuzzFile $ top </> dir </> files !! i
+
+existingDirIncludingTop :: IO FilePath
+existingDirIncludingTop = do
+	dirs <- filter isFuzzDir <$> getDirectoryContents "."
+	if null dirs
+		then return "."
+		else do
+			n <- getStdRandom $ randomR (0, length dirs)
+			return $ ("." : dirs) !! n
 
 existingDir :: IO (Maybe FuzzDir)
 existingDir = do
-	dirs <- filter isFuzzDir <$> getDirectoryContents "."
-	if null dirs
-		then return Nothing
-		else do
-			n <- getStdRandom $ randomR (0, length dirs)
-			return $ Just $ FuzzDir $ ("." : dirs) !! n
+	d <- existingDirIncludingTop
+	return $ if isFuzzDir d
+		then Just $ FuzzDir d
+		else Nothing
 
 newFile :: IO (Maybe FuzzFile)
 newFile = go (100 :: Int)