Use Cabal directly in place of ghc-cabal + make build root configurable (#531)
[hadrian.git] / src / Oracles / ModuleFiles.hs
1 {-# LANGUAGE TypeFamilies #-}
2 module Oracles.ModuleFiles (
3 decodeModule, encodeModule, findGenerator, hsSources, hsObjects, moduleFilesOracle
4 ) where
5
6 import qualified Data.HashMap.Strict as Map
7
8 import Base
9 import Builder
10 import Context
11 import Expression
12 import GHC
13 import Hadrian.Haskell.Cabal.PackageData as PD
14
15 newtype ModuleFiles = ModuleFiles (Stage, Package)
16 deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
17 type instance RuleResult ModuleFiles = [Maybe FilePath]
18
19 newtype Generator = Generator (Stage, Package, FilePath)
20 deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
21 type instance RuleResult Generator = Maybe FilePath
22
23 -- | We scan for the following Haskell source extensions when looking for module
24 -- files. Note, we do not list "*.(l)hs-boot" files here, as they can never
25 -- appear by themselves and always have accompanying "*.(l)hs" master files.
26 haskellExtensions :: [String]
27 haskellExtensions = [".hs", ".lhs"]
28
29 -- | Non-Haskell source extensions and corresponding builders.
30 otherExtensions :: Stage -> [(String, Builder)]
31 otherExtensions stage = [ (".x" , Alex )
32 , (".y" , Happy )
33 , (".ly" , Happy )
34 , (".hsc", Hsc2Hs stage) ]
35
36 -- | We match the following file patterns when looking for module files.
37 moduleFilePatterns :: Stage -> [FilePattern]
38 moduleFilePatterns stage = map ("*" ++) $ haskellExtensions ++ map fst (otherExtensions stage)
39
40 -- | Given a FilePath determine the corresponding builder.
41 determineBuilder :: Stage -> FilePath -> Maybe Builder
42 determineBuilder stage file = lookup (takeExtension file) (otherExtensions stage)
43
44 -- | Given a module name extract the directory and file name, e.g.:
45 --
46 -- > decodeModule "Data.Functor.Identity" == ("Data/Functor", "Identity")
47 -- > decodeModule "Prelude" == ("", "Prelude")
48 decodeModule :: String -> (FilePath, String)
49 decodeModule modName = (intercalate "/" (init xs), last xs)
50 where
51 xs = words $ replaceEq '.' ' ' modName
52
53 -- | Given the directory and file name find the corresponding module name, e.g.:
54 --
55 -- > encodeModule "Data/Functor" "Identity.hs" == "Data.Functor.Identity"
56 -- > encodeModule "" "Prelude" == "Prelude"
57 -- > uncurry encodeModule (decodeModule name) == name
58 encodeModule :: FilePath -> String -> String
59 encodeModule dir file
60 | dir == "" = takeBaseName file
61 | otherwise = replaceEq '/' '.' dir ++ '.' : takeBaseName file
62
63 -- | Find the generator for a given 'Context' and a source file. For example:
64 -- findGenerator (Context Stage1 compiler vanilla)
65 -- "_build/stage1/compiler/build/Lexer.hs"
66 -- == Just ("compiler/parser/Lexer.x", Alex)
67 -- findGenerator (Context Stage1 base vanilla)
68 -- "_build/stage1/base/build/Prelude.hs"
69 -- == Nothing
70 findGenerator :: Context -> FilePath -> Action (Maybe (FilePath, Builder))
71 findGenerator Context {..} file = do
72 maybeSource <- askOracle $ Generator (stage, package, file)
73 return $ do
74 source <- maybeSource
75 builder <- determineBuilder stage source
76 return (source, builder)
77
78 -- | Find all Haskell source files for a given 'Context'.
79 hsSources :: Context -> Action [FilePath]
80 hsSources context = do
81 let modFile (m, Nothing ) = generatedFile context m
82 modFile (m, Just file )
83 | takeExtension file `elem` haskellExtensions = return file
84 | otherwise = generatedFile context m
85 mapM modFile =<< contextFiles context
86
87 -- | Find all Haskell object files for a given 'Context'. Note: this is a much
88 -- simpler function compared to 'hsSources', because all object files live in
89 -- the build directory regardless of whether they are generated or not.
90 hsObjects :: Context -> Action [FilePath]
91 hsObjects context = do
92 modules <- interpretInContext context (getPackageData PD.modules)
93 mapM (objectPath context . moduleSource) modules
94
95 -- | Generated module files live in the 'Context' specific build directory.
96 generatedFile :: Context -> String -> Action FilePath
97 generatedFile context moduleName = do
98 path <- buildPath context
99 return $ path -/- moduleSource moduleName
100
101 moduleSource :: String -> FilePath
102 moduleSource moduleName = replaceEq '.' '/' moduleName <.> "hs"
103
104 -- | Module files for a given 'Context'.
105 contextFiles :: Context -> Action [(String, Maybe FilePath)]
106 contextFiles context@Context {..} = do
107 modules <- fmap sort . interpretInContext context $
108 getPackageData PD.modules
109 zip modules <$> askOracle (ModuleFiles (stage, package))
110
111 -- | This is an important oracle whose role is to find and cache module source
112 -- files. It takes a 'Stage' and a 'Package', looks up corresponding source
113 -- directories @dirs@ and a sorted list of module names @modules@, and for each
114 -- module, e.g. @A.B.C@, returns a 'FilePath' of the form @dir/A/B/C.extension@,
115 -- such that @dir@ belongs to @dirs@, and file @dir/A/B/C.extension@ exists, or
116 -- 'Nothing' if there is no such file. If more than one matching file is found
117 -- an error is raised. For example, for 'Stage1' and 'compiler', @dirs@ will
118 -- contain ["compiler/codeGen", "compiler/parser"], and @modules@ will contain
119 -- ["CodeGen.Platform.ARM", "Config", "Lexer"]; the oracle will produce a list
120 -- containing [Just "compiler/codeGen/CodeGen/Platform/ARM.hs", Nothing,
121 -- Just "compiler/parser/Lexer.x"]. The oracle ignores @.(l)hs-boot@ files.
122 moduleFilesOracle :: Rules ()
123 moduleFilesOracle = void $ do
124 void . addOracle $ \(ModuleFiles (stage, package)) -> do
125 let context = vanillaContext stage package
126 srcDirs <- interpretInContext context (getPackageData PD.srcDirs)
127 modules <- fmap sort $ interpretInContext context (getPackageData PD.modules)
128 autogen <- autogenPath context
129 let dirs = autogen : map (pkgPath package -/-) srcDirs
130 modDirFiles = groupSort $ map decodeModule modules
131 result <- concatForM dirs $ \dir -> do
132 todo <- filterM (doesDirectoryExist . (dir -/-) . fst) modDirFiles
133 forM todo $ \(mDir, mFiles) -> do
134 let fullDir = unifyPath $ dir -/- mDir
135 files <- getDirectoryFiles fullDir (moduleFilePatterns stage)
136 let cmp f = compare (dropExtension f)
137 found = intersectOrd cmp files mFiles
138 return (map (fullDir -/-) found, mDir)
139 let pairs = sort [ (encodeModule d f, f) | (fs, d) <- result, f <- fs ]
140 multi = [ (m, f1, f2) | (m, f1):(n, f2):_ <- tails pairs, m == n ]
141 unless (null multi) $ do
142 let (m, f1, f2) = head multi
143 error $ "Module " ++ m ++ " has more than one source file: "
144 ++ f1 ++ " and " ++ f2 ++ "."
145 return $ lookupAll modules pairs
146
147 -- Optimisation: we discard Haskell files here, because they are never used
148 -- as generators, and hence would be discarded in 'findGenerator' anyway.
149 generators <- newCache $ \(stage, package) -> do
150 let context = vanillaContext stage package
151 files <- contextFiles context
152 list <- sequence [ (,src) <$> generatedFile context modName
153 | (modName, Just src) <- files
154 , takeExtension src `notElem` haskellExtensions ]
155 return $ Map.fromList list
156
157 addOracle $ \(Generator (stage, package, file)) ->
158 Map.lookup file <$> generators (stage, package)