501bc89736e6162b6ba55c2d317d439a92ff9b9d
[hadrian.git] / src / Oracles / ModuleFiles.hs
1 {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
2 module Oracles.ModuleFiles (
3 moduleFiles, haskellModuleFiles, moduleFilesOracle, findModuleFiles
4 ) where
5
6 import Base
7 import Context
8 import Oracles.PackageData
9 import Package
10 import Settings.Paths
11
12 newtype ModuleFilesKey = ModuleFilesKey ([FilePath], [String])
13 deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
14
15 moduleFiles :: Context -> Action [FilePath]
16 moduleFiles context @ (Context {..}) = do
17 let path = contextPath context
18 srcDirs <- fmap sort . pkgDataList $ SrcDirs path
19 modules <- fmap sort . pkgDataList $ Modules path
20 let dirs = [ pkgPath package -/- dir | dir <- srcDirs ]
21 fmap catMaybes $ findModuleFiles dirs modules
22
23 haskellModuleFiles :: Context -> Action ([FilePath], [String])
24 haskellModuleFiles context @ (Context {..}) = do
25 let path = contextPath context
26 autogen = path -/- "build/autogen"
27 dropPkgPath = drop $ length (pkgPath package) + 1
28 srcDirs <- fmap sort . pkgDataList $ SrcDirs path
29 modules <- fmap sort . pkgDataList $ Modules path
30 let dirs = [ pkgPath package -/- dir | dir <- srcDirs ]
31 foundSrcDirs <- findModuleFiles dirs modules
32 foundAutogen <- findModuleFiles [autogen] modules
33 found <- sequence $ zipWith3 addSources modules foundSrcDirs foundAutogen
34
35 let missingMods = map fst . filter (isNothing . snd) $ zip modules found
36 otherFileToMod = replaceEq '/' '.' . dropExtension . dropPkgPath
37 (haskellFiles, otherFiles) = partition ("//*hs" ?==) $ catMaybes found
38
39 return (haskellFiles, missingMods ++ map otherFileToMod otherFiles)
40 where
41 addSources _ Nothing r = return r
42 addSources _ l Nothing = return l
43 addSources m (Just f1) (Just f2) = errorMultipleSources m f1 f2
44
45 -- | This is an important oracle whose role is to find and cache module source
46 -- files. More specifically, it takes a list of directories @dirs@ and a sorted
47 -- list of module names @modules@ as arguments, and for each module, e.g.
48 -- @A.B.C@, returns a 'FilePath' of the form @dir/A/B/C.extension@, such that
49 -- @dir@ belongs to @dirs@, and file @dir/A/B/C.extension@ exists, or 'Nothing'
50 -- if there is no such file. If more than one matching file is found an error is
51 -- raised. For example, for the 'compiler' package given
52 -- @dirs = ["compiler/codeGen", "compiler/parser"]@, and
53 -- @modules = ["CodeGen.Platform.ARM", "Lexer", "Missing.Module"]@, it produces
54 -- @[Just "compiler/codeGen/CodeGen/Platform/ARM.hs",
55 -- Just "compiler/parser/Lexer.x", Nothing]@.
56 findModuleFiles :: [FilePath] -> [String] -> Action [Maybe FilePath]
57 findModuleFiles dirs modules = askOracle $ ModuleFilesKey (dirs, modules)
58
59 moduleFilesOracle :: Rules ()
60 moduleFilesOracle = void $
61 addOracle $ \(ModuleFilesKey (dirs, modules)) -> do
62 let decodedPairs = map decodeModule modules
63 modDirFiles = map (bimap head id . unzip)
64 . groupBy ((==) `on` fst) $ decodedPairs
65
66 result <- fmap concat . forM dirs $ \dir -> do
67 todo <- filterM (doesDirectoryExist . (dir -/-) . fst) modDirFiles
68 forM todo $ \(mDir, mFiles) -> do
69 let fullDir = dir -/- mDir
70 files <- getDirectoryFiles fullDir ["*"]
71 let noBoot = filter (not . (isSuffixOf "-boot")) files
72 cmp fe f = compare (dropExtension fe) f
73 found = intersectOrd cmp noBoot mFiles
74 return (map (fullDir -/-) found, mDir)
75
76 let pairs = sort [ (encodeModule d f, f) | (fs, d) <- result, f <- fs ]
77 multi = [ (m, f1, f2) | (m, f1):(n, f2):_ <- tails pairs, m == n ]
78
79 unless (null multi) $ do
80 let (m, f1, f2) = head multi
81 errorMultipleSources m f1 f2
82
83 return $ lookupAll modules pairs
84
85 errorMultipleSources :: String -> FilePath -> FilePath -> Action a
86 errorMultipleSources m f1 f2 = putError $ "Module " ++ m ++
87 " has more than one source file: " ++ f1 ++ " and " ++ f2 ++ "."