630a05f5b51dfe71545a621b7d146668a056c00f
[hadrian.git] / src / Oracles / ModuleFiles.hs
1 {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
2 module Oracles.ModuleFiles (
3 findGenerator, haskellSources, moduleFilesOracle
4 ) where
5
6 import qualified Data.HashMap.Strict as Map
7
8 import Base
9 import Context
10 import Expression
11 import Oracles.PackageData
12 import Settings.Paths
13
14 newtype ModuleFilesKey = ModuleFilesKey Context
15 deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
16
17 newtype Generator = Generator (Context, FilePath)
18 deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
19
20 -- The following generators and corresponding source extensions are supported:
21 determineBuilder :: FilePath -> Maybe Builder
22 determineBuilder file = case takeExtension file of
23 ".x" -> Just Alex
24 ".y" -> Just Happy
25 ".ly" -> Just Happy
26 ".hsc" -> Just Hsc2Hs
27 _ -> Nothing
28
29 -- | Find the generator for a given 'Context' and a source file. For example:
30 -- findGenerator (Context Stage1 compiler vanilla)
31 -- ".build/stage1/compiler/build/Lexer.hs"
32 -- == Just ("compiler/parser/Lexer.x", Alex)
33 -- findGenerator (Context Stage1 base vanilla)
34 -- ".build/stage1/base/build/Prelude.hs"
35 -- == Nothing
36 findGenerator :: Context -> FilePath -> Action (Maybe (FilePath, Builder))
37 findGenerator context file = askOracle $ Generator (context, file)
38
39 -- | Find all Haskell source files for a given 'Context'.
40 haskellSources :: Context -> Action [FilePath]
41 haskellSources context = do
42 let autogen = contextPath context -/- "build/autogen"
43 -- Generated source files live in build/ and have extension "hs", except
44 -- that GHC/Prim.hs lives in build/autogen/. TODO: fix the inconsistency?
45 let modFile ("GHC.Prim", _) = autogen -/- "GHC/Prim.hs"
46 modFile (m, Nothing ) = generatedFile context m
47 modFile (m, Just file ) | "//*hs" ?== file = file
48 | otherwise = modFile (m, Nothing)
49 map modFile <$> contextFiles context
50
51 generatedFile :: Context -> String -> FilePath
52 generatedFile context moduleName =
53 contextPath context -/- "build" -/- replaceEq '.' '/' moduleName <.> "hs"
54
55 contextFiles :: Context -> Action [(String, Maybe FilePath)]
56 contextFiles context @ Context {..} = do
57 let path = contextPath context
58 modules <- fmap sort . pkgDataList $ Modules path
59 zip modules <$> askOracle (ModuleFilesKey context)
60
61 -- | This is an important oracle whose role is to find and cache module source
62 -- files. It takes a 'Context', looks up corresponding source directories @dirs@
63 -- and sorted list of module names @modules@, and for each module, e.g.
64 -- @A.B.C@, returns a 'FilePath' of the form @dir/A/B/C.extension@, such that
65 -- @dir@ belongs to @dirs@, and file @dir/A/B/C.extension@ exists, or 'Nothing'
66 -- if there is no such file. If more than one matching file is found an error is
67 -- raised. For example, for @Context Stage1 compiler vanilla@, @dirs@ will
68 -- contain ["compiler/codeGen", "compiler/parser"], and @modules@ will contain
69 -- ["CodeGen.Platform.ARM", "Config", "Lexer"]; the oracle will produce a list
70 -- containing [Just "compiler/codeGen/CodeGen/Platform/ARM.hs", Nothing,
71 -- Just "compiler/parser/Lexer.x"].
72 moduleFilesOracle :: Rules ()
73 moduleFilesOracle = void $ do
74 void $ addOracle $ \(ModuleFilesKey context) -> do
75 let path = contextPath context
76 autogen = path -/- "build/autogen"
77 srcDirs <- pkgDataList $ SrcDirs path
78 modules <- fmap sort . pkgDataList $ Modules path
79 let dirs = autogen : map (pkgPath (package context) -/-) srcDirs
80 modDirFiles = groupSort $ map decodeModule modules
81 result <- fmap concat . forM dirs $ \dir -> do
82 todo <- filterM (doesDirectoryExist . (dir -/-) . fst) modDirFiles
83 forM todo $ \(mDir, mFiles) -> do
84 let fullDir = dir -/- mDir
85 files <- getDirectoryFiles fullDir ["*"]
86 let noBoot = filter (not . (isSuffixOf "-boot")) files
87 cmp fe f = compare (dropExtension fe) f
88 found = intersectOrd cmp noBoot mFiles
89 return (map (fullDir -/-) found, mDir)
90 let pairs = sort [ (encodeModule d f, f) | (fs, d) <- result, f <- fs ]
91 multi = [ (m, f1, f2) | (m, f1):(n, f2):_ <- tails pairs, m == n ]
92 unless (null multi) $ do
93 let (m, f1, f2) = head multi
94 putError $ "Module " ++ m ++ " has more than one source file: "
95 ++ f1 ++ " and " ++ f2 ++ "."
96 return $ lookupAll modules pairs
97
98 gens <- newCache $ \context -> do
99 files <- contextFiles context
100 return $ Map.fromList [ (generatedFile context modName, (src, builder))
101 | (modName, Just src) <- files
102 , let Just builder = determineBuilder src ]
103
104 addOracle $ \(Generator (context, file)) -> Map.lookup file <$> gens context