From 48b5858b9b37e4190c475558a6c88dc923ec5c5a Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 18 Aug 2015 23:06:00 +0200
Subject: Fix path handling in test module loader.
---
haddock-test/src/Test/Haddock/Config.hs | 20 ++++++++++++++++----
1 file changed, 16 insertions(+), 4 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 9fca3348..f3056061 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -241,8 +241,8 @@ processFileArgs dcfg [] =
processFileArgs' dcfg . filter isValidEntry =<< getDirectoryContents srcDir
where
isValidEntry entry
- | hasExtension entry = takeExtension entry `elem` [".hs", ".lhs"]
- | otherwise = entry /= "." && entry /= ".."
+ | hasExtension entry = isSourceFile entry
+ | otherwise = isRealDir entry
srcDir = dcfgSrcDir dcfg
processFileArgs dcfg args = processFileArgs' dcfg args
@@ -255,12 +255,24 @@ processFileArgs' dcfg args = do
, tpkgFiles = map (srcDir </>) mdls
}
otherPkgs <- forM dirs $ \dir -> do
- files <- getDirectoryContents (srcDir </> dir)
+ let srcDir' = srcDir </> dir
+ files <- filterM (isModule dir) =<< getDirectoryContents srcDir'
pure $ TestPackage
{ tpkgName = dir
- , tpkgFiles = map ((srcDir </> dir) </>) files
+ , tpkgFiles = map (srcDir' </>) files
}
pure $ rootPkg:otherPkgs
where
doesDirectoryExist' path = doesDirectoryExist (srcDir </> path)
+ isModule dir file = (isSourceFile file &&) <$>
+ doesFileExist (srcDir </> dir </> file)
+ doesFileExist' dir path = doesFileExist (srcDir </> dir </> path)
srcDir = dcfgSrcDir dcfg
+
+
+isSourceFile :: FilePath -> Bool
+isSourceFile file = takeExtension file `elem` [".hs", ".lhs"]
+
+
+isRealDir :: FilePath -> Bool
+isRealDir dir = not $ dir `elem` [".", ".."]
--
cgit v1.2.3