Do not unify paths on each -/- invocation.
[hadrian.git] / src / Oracles / ModuleFiles.hs
1 {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
2 module Oracles.ModuleFiles (
3 decodeModule, encodeModule, 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 (Stage, Package)
15 deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
16
17 newtype Generator = Generator (Stage, Package, 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 -- | Given a module name extract the directory and file name, e.g.:
30 --
31 -- > decodeModule "Data.Functor.Identity" == ("Data/Functor/", "Identity")
32 -- > decodeModule "Prelude" == ("./", "Prelude")
33 decodeModule :: String -> (FilePath, String)
34 decodeModule = splitFileName . replaceEq '.' '/'
35
36 -- | Given the directory and file name find the corresponding module name, e.g.:
37 --
38 -- > encodeModule "Data/Functor/" "Identity.hs" == "Data.Functor.Identity"
39 -- > encodeModule "./" "Prelude" == "Prelude"
40 -- > uncurry encodeModule (decodeModule name) == name
41 encodeModule :: FilePath -> String -> String
42 encodeModule dir file
43 | dir == "./" = replaceEq '/' '.' $ takeBaseName file
44 | otherwise = replaceEq '/' '.' $ dir ++ takeBaseName file
45
46 -- | Find the generator for a given 'Context' and a source file. For example:
47 -- findGenerator (Context Stage1 compiler vanilla)
48 -- ".build/stage1/compiler/build/Lexer.hs"
49 -- == Just ("compiler/parser/Lexer.x", Alex)
50 -- findGenerator (Context Stage1 base vanilla)
51 -- ".build/stage1/base/build/Prelude.hs"
52 -- == Nothing
53 findGenerator :: Context -> FilePath -> Action (Maybe (FilePath, Builder))
54 findGenerator Context {..} file = do
55 maybeSource <- askOracle $ Generator (stage, package, file)
56 return $ do
57 source <- maybeSource
58 builder <- determineBuilder source
59 return (source, builder)
60
61 -- | Find all Haskell source files for a given 'Context'.
62 haskellSources :: Context -> Action [FilePath]
63 haskellSources context = do
64 let autogen = buildPath context -/- "autogen"
65 -- Generated source files live in buildPath and have extension "hs", except
66 -- for GHC/Prim.hs that lives in autogen. TODO: fix the inconsistency?
67 let modFile ("GHC.Prim", _) = autogen -/- "GHC/Prim.hs"
68 modFile (m, Nothing ) = generatedFile context m
69 modFile (m, Just file )
70 | takeExtension file `elem` [".hs", ".lhs"] = file
71 | otherwise = generatedFile context m
72 map modFile <$> contextFiles context
73
74 generatedFile :: Context -> String -> FilePath
75 generatedFile context moduleName =
76 buildPath context -/- replaceEq '.' '/' moduleName <.> "hs"
77
78 contextFiles :: Context -> Action [(String, Maybe FilePath)]
79 contextFiles context@Context {..} = do
80 modules <- fmap sort . pkgDataList . Modules $ buildPath context
81 zip modules <$> askOracle (ModuleFilesKey (stage, package))
82
83 -- | This is an important oracle whose role is to find and cache module source
84 -- files. It takes a 'Stage' and a 'Package', looks up corresponding source
85 -- directories @dirs@ and a sorted list of module names @modules@, and for each
86 -- module, e.g. @A.B.C@, returns a 'FilePath' of the form @dir/A/B/C.extension@,
87 -- such that @dir@ belongs to @dirs@, and file @dir/A/B/C.extension@ exists, or
88 -- 'Nothing' if there is no such file. If more than one matching file is found
89 -- an error is raised. For example, for 'Stage1' and 'compiler', @dirs@ will
90 -- contain ["compiler/codeGen", "compiler/parser"], and @modules@ will contain
91 -- ["CodeGen.Platform.ARM", "Config", "Lexer"]; the oracle will produce a list
92 -- containing [Just "compiler/codeGen/CodeGen/Platform/ARM.hs", Nothing,
93 -- Just "compiler/parser/Lexer.x"]. The oracle ignores @.(l)hs-boot@ files.
94 moduleFilesOracle :: Rules ()
95 moduleFilesOracle = void $ do
96 void $ addOracle $ \(ModuleFilesKey (stage, package)) -> do
97 let path = buildPath $ vanillaContext stage package
98 srcDirs <- pkgDataList $ SrcDirs path
99 modules <- fmap sort . pkgDataList $ Modules path
100 let dirs = (path -/- "autogen") : map (pkgPath package -/-) srcDirs
101 modDirFiles = groupSort $ map decodeModule modules
102 result <- fmap concat . forM dirs $ \dir -> do
103 todo <- filterM (doesDirectoryExist . (dir -/-) . fst) modDirFiles
104 forM todo $ \(mDir, mFiles) -> do
105 let fullDir = dir -/- mDir
106 files <- getDirectoryFiles fullDir ["*"]
107 let noBoot = filter (not . (isSuffixOf "-boot")) files
108 cmp fe f = compare (dropExtension fe) f
109 found = intersectOrd cmp noBoot mFiles
110 return (map (fullDir -/-) found, mDir)
111 let pairs = sort [ (encodeModule d f, f) | (fs, d) <- result, f <- fs ]
112 multi = [ (m, f1, f2) | (m, f1):(n, f2):_ <- tails pairs, m == n ]
113 unless (null multi) $ do
114 let (m, f1, f2) = head multi
115 putError $ "Module " ++ m ++ " has more than one source file: "
116 ++ f1 ++ " and " ++ f2 ++ "."
117 return $ lookupAll modules pairs
118
119 -- Optimisation: we discard .(l)hs files here, because they are never used
120 -- as generators, and hence would be discarded in 'findGenerator' anyway.
121 generators <- newCache $ \(stage, package) -> do
122 let context = vanillaContext stage package
123 files <- contextFiles context
124 return $ Map.fromList [ (generatedFile context modName, src)
125 | (modName, Just src) <- files
126 , takeExtension src `notElem` [".hs", ".lhs"] ]
127
128 addOracle $ \(Generator (stage, package, file)) ->
129 Map.lookup file <$> generators (stage, package)