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