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