1{-# LANGUAGE OverloadedStrings #-} 2 3import qualified Distribution.ModuleName as ModuleName 4import Distribution.PackageDescription 5import Distribution.PackageDescription.Parsec 6 (parseGenericPackageDescription, runParseResult) 7import Distribution.Verbosity (silent) 8 9import Control.Monad (liftM, filterM) 10import Data.List (isPrefixOf, isSuffixOf, sort) 11import System.Directory (canonicalizePath, doesFileExist, setCurrentDirectory) 12import System.Environment (getArgs, getProgName) 13import System.FilePath ((</>), takeDirectory, takeExtension, takeFileName) 14import System.Process (readProcess) 15 16 17import qualified Data.ByteString as BS 18import qualified Data.ByteString.Char8 as BS8 19import qualified System.IO as IO 20 21main' :: FilePath -> FilePath -> IO () 22main' templateFp fp' = do 23 fp <- canonicalizePath fp' 24 setCurrentDirectory (takeDirectory fp) 25 print $ takeDirectory fp 26 27 -- Read cabal file, so we can determine test modules 28 contents <- BS.readFile fp 29 cabal <- 30 case snd . runParseResult . parseGenericPackageDescription $ contents of 31 Right x -> pure x 32 Left (_mver, errs) -> fail (show errs) 33 34 -- We skip some files 35 testModuleFiles <- getOtherModulesFiles cabal 36 let skipPredicates' = skipPredicates ++ map (==) testModuleFiles 37 print testModuleFiles 38 39 -- Read all files git knows about under "tests" 40 files0 <- lines <$> readProcess "git" ["ls-files", "tests"] "" 41 42 -- Filter 43 let files1 = filter (\f -> takeExtension f `elem` whitelistedExtensionss || 44 takeFileName f `elem` whitelistedFiles) 45 files0 46 let files2 = filter (\f -> not $ any ($ f) skipPredicates') files1 47 let files3 = sort files2 48 let files = files3 49 50 -- Read current file 51 templateContents <- BS.readFile templateFp 52 let topLine' = BS8.pack topLine 53 bottomLine' = BS8.pack bottomLine 54 inputLines = BS8.lines templateContents 55 linesBefore = takeWhile (/= topLine') inputLines 56 linesAfter = dropWhile (/= bottomLine') inputLines 57 58 -- Output 59 let outputLines = linesBefore ++ [topLine'] 60 ++ map ((<>) " " . BS8.pack) files ++ linesAfter 61 BS.writeFile templateFp (BS8.unlines outputLines) 62 63 64topLine, bottomLine :: String 65topLine = " -- BEGIN gen-extra-source-files" 66bottomLine = " -- END gen-extra-source-files" 67 68whitelistedFiles :: [FilePath] 69whitelistedFiles = [ "ghc", "ghc-pkg", "ghc-7.10" 70 , "ghc-pkg-7.10", "ghc-pkg-ghc-7.10" ] 71 72whitelistedExtensionss :: [String] 73whitelistedExtensionss = map ('.' : ) 74 [ "hs", "lhs", "c", "h", "sh", "cabal", "hsc" 75 , "err", "out", "in", "project", "format", "errors", "expr" 76 , "check" 77 ] 78 79getOtherModulesFiles :: GenericPackageDescription -> IO [FilePath] 80getOtherModulesFiles gpd = do 81 mainModules <- liftM concat . mapM findMainModules $ testSuites 82 otherModules' <- liftM concat . mapM findOtherModules $ testSuites 83 84 return $ mainModules ++ otherModules' 85 where 86 testSuites :: [TestSuite] 87 testSuites = map (foldMap id . snd) (condTestSuites gpd) 88 89 findMainModules, findOtherModules :: TestSuite -> IO [FilePath] 90 findMainModules ts = findModules (mainModule . testInterface $ ts) ts 91 findOtherModules ts = 92 findModules (map fromModuleName . otherModules . testBuildInfo $ ts) ts 93 94 findModules :: [FilePath] -> TestSuite -> IO [FilePath] 95 findModules filenames ts = filterM doesFileExist 96 [ d </> f | d <- locations, f <- filenames ] 97 where locations = hsSourceDirs . testBuildInfo $ ts 98 99 fromModuleName mn = ModuleName.toFilePath mn ++ ".hs" 100 101 mainModule (TestSuiteLibV09 _ mn) = [fromModuleName mn] 102 mainModule (TestSuiteExeV10 _ fp) = [fp] 103 mainModule _ = [] 104 105skipPredicates :: [FilePath -> Bool] 106skipPredicates = 107 [ isSuffixOf "register.sh" 108 ] 109 110main :: IO () 111main = do 112 args <- getArgs 113 case args of 114 [fp] -> main' fp fp 115 [fp,fp'] -> main' fp fp' 116 _ -> do 117 progName <- getProgName 118 putStrLn "Error too few arguments!" 119 putStrLn $ "Usage: " ++ progName ++ " <FILE | FILE CABAL>" 120 putStrLn $ " where FILE is Cabal.cabal, cabal-testsuite.cabal, " 121 ++ "or cabal-install.cabal" 122