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