summaryrefslogtreecommitdiff
path: root/hadrian/src/Oracles/ModuleFiles.hs
diff options
context:
space:
mode:
Diffstat (limited to 'hadrian/src/Oracles/ModuleFiles.hs')
-rw-r--r--hadrian/src/Oracles/ModuleFiles.hs182
1 files changed, 182 insertions, 0 deletions
diff --git a/hadrian/src/Oracles/ModuleFiles.hs b/hadrian/src/Oracles/ModuleFiles.hs
new file mode 100644
index 0000000000..1e508c0090
--- /dev/null
+++ b/hadrian/src/Oracles/ModuleFiles.hs
@@ -0,0 +1,182 @@
+{-# 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 ) = 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)
+
+-- | 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
+ 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)