Implement ModuleFiles oracle for caching the search of module files of a package.
[hadrian.git] / src / Oracles / ModuleFiles.hs
1 {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
2 module Oracles.ModuleFiles (moduleFiles, haskellModuleFiles, moduleFilesOracle) where
3
4 import Base hiding (exe)
5 import Distribution.ModuleName
6 import Distribution.PackageDescription
7 import Distribution.PackageDescription.Parse
8 import Distribution.Verbosity
9 import GHC
10 import Oracles.PackageData
11 import Package hiding (library)
12 import Stage
13 import Settings.TargetDirectory
14
15 newtype ModuleFilesKey = ModuleFilesKey (Package, [FilePath])
16 deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
17
18 moduleFiles :: Stage -> Package -> Action [FilePath]
19 moduleFiles stage pkg = do
20 let path = targetPath stage pkg
21 modules <- fmap sort . pkgDataList $ Modules path
22 (found, _ :: [FilePath]) <- askOracle $ ModuleFilesKey (pkg, [])
23 let cmp (m1, _) m2 = compare m1 m2
24 foundFiles = map snd $ intersectOrd cmp found modules
25 return foundFiles
26
27 haskellModuleFiles :: Stage -> Package -> Action ([FilePath], [String])
28 haskellModuleFiles stage pkg = do
29 let path = targetPath stage pkg
30 autogen = path -/- "build/autogen"
31 modules <- fmap sort . pkgDataList $ Modules path
32 (found, missingMods) <- askOracle $ ModuleFilesKey (pkg, [autogen])
33 let cmp (m1, _) m2 = compare m1 m2
34 foundFiles = map snd $ intersectOrd cmp found modules
35 otherMods = map (replaceEq '/' '.' . dropExtension) otherFiles
36 (haskellFiles, otherFiles) = partition ("//*hs" ?==) foundFiles
37 return (haskellFiles, missingMods ++ otherMods)
38
39 extract :: Monoid a => Maybe (CondTree v c a) -> a
40 extract Nothing = mempty
41 extract (Just (CondNode leaf _ ifs)) = leaf <> mconcat (map f ifs)
42 where
43 f (_, t, mt) = extract (Just t) <> extract mt
44
45 -- Look up Haskell source directories and module names of a package
46 packageInfo :: Package -> Action ([FilePath], [ModuleName])
47 packageInfo pkg
48 | pkg == hp2ps = return (["."], [])
49 | otherwise = do
50 need [pkgCabalFile pkg]
51 pd <- liftIO . readPackageDescription silent $ pkgCabalFile pkg
52
53 let lib = extract $ condLibrary pd
54 exe = extract . Just . snd . head $ condExecutables pd
55
56 let (srcDirs, modules) = if lib /= mempty
57 then ( hsSourceDirs $ libBuildInfo lib, libModules lib)
58 else ( hsSourceDirs $ buildInfo exe
59 , [fromString . dropExtension $ modulePath exe]
60 ++ exeModules exe)
61
62 return (if null srcDirs then ["."] else srcDirs, modules)
63
64 moduleFilesOracle :: Rules ()
65 moduleFilesOracle = do
66 answer <- newCache $ \(pkg, extraDirs) -> do
67 putOracle $ "Searching module files of package " ++ pkgName pkg ++ "..."
68 unless (null extraDirs) $ putOracle $ "Extra directory = " ++ show extraDirs
69
70 (srcDirs, modules) <- packageInfo pkg
71
72 let dirs = extraDirs ++ [ pkgPath pkg -/- dir | dir <- srcDirs ]
73 decodedPairs = sort $ map (splitFileName . toFilePath) modules
74 modDirFiles = map (bimap head sort . unzip)
75 . groupBy ((==) `on` fst) $ decodedPairs
76
77 result <- fmap concat . forM dirs $ \dir -> do
78 todo <- filterM (doesDirectoryExist . (dir -/-) . fst) modDirFiles
79 forM todo $ \(mDir, mFiles) -> do
80 let fullDir = dir -/- mDir
81 files <- getDirectoryFiles fullDir ["*"]
82 let noBoot = filter (not . (isSuffixOf "-boot")) files
83 cmp fe f = compare (dropExtension fe) f
84 found = intersectOrd cmp noBoot mFiles
85 return (map (fullDir -/-) found, (mDir, map dropExtension found))
86
87 let foundFiles = sort [ (encodeModule d f, f)
88 | (fs, (d, _)) <- result, f <- fs ]
89 foundPairs = [ (d, f) | (d, fs) <- map snd result, f <- fs ]
90 missingPairs = decodedPairs `minusOrd` sort foundPairs
91 missingMods = map (uncurry encodeModule) missingPairs
92
93 return (foundFiles, missingMods)
94
95 _ <- addOracle $ \(ModuleFilesKey query) -> answer query
96 return ()