From c2a4125e3a5158078d8c172a840f7292dcf3ab28 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 18 Aug 2015 20:32:12 +0200
Subject: Fix path handling in test runner.
---
haddock-test/src/Test/Haddock/Config.hs | 25 ++++++++++---------------
1 file changed, 10 insertions(+), 15 deletions(-)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index 15a53829..1b89e276 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -238,34 +238,29 @@ defaultDiffTool =
processFileArgs :: DirConfig -> [String] -> IO [TestPackage]
processFileArgs dcfg [] =
- processFileArgs dcfg . filter isValidEntry =<< getDirectoryContents srcDir
+ processFileArgs' dcfg . filter isValidEntry =<< getDirectoryContents srcDir
where
- isValidEntry entry = entry /= "." && entry /= ".."
+ isValidEntry entry
+ | hasExtension entry = takeExtension entry `elem` [".hs", ".lhs"]
+ | otherwise = entry /= "." && entry /= ".."
srcDir = dcfgSrcDir dcfg
processFileArgs dcfg args = processFileArgs' dcfg args
processFileArgs' :: DirConfig -> [String] -> IO [TestPackage]
processFileArgs' dcfg args = do
- (mdls, dirs) <- partitionM doesDirectoryExist' args
+ (dirs, mdls) <- partitionM doesDirectoryExist' . map takeBaseName $ args
rootPkg <- pure $ TestPackage
{ tpkgName = ""
- , tpkgFiles = map (processFileArg dcfg) mdls
+ , tpkgFiles = map (srcDir </>) mdls
}
otherPkgs <- forM dirs $ \dir -> do
- files <- getDirectoryContents dir
+ files <- getDirectoryContents (srcDir </> dir)
pure $ TestPackage
{ tpkgName = dir
- , tpkgFiles = map ((dcfgSrcDir dcfg </> dir) </>) files
+ , tpkgFiles = map ((srcDir </> dir) </>) files
}
pure $ rootPkg:otherPkgs
where
- doesDirectoryExist' path = doesDirectoryExist (dcfgSrcDir dcfg </> path)
-
-
-processFileArg :: DirConfig -> String -> FilePath
-processFileArg dcfg arg
- | isSourceFile arg = arg
- | otherwise = dcfgSrcDir dcfg </> arg </> ".hs"
- where
- isSourceFile path = takeExtension path `elem` [".hs", ".lhs"]
+ doesDirectoryExist' path = doesDirectoryExist (srcDir </> path)
+ srcDir = dcfgSrcDir dcfg
--
cgit v1.2.3