Commit cf825feb authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Implement ModuleFiles oracle for caching the search of module files of a package.

parent ecdeae76
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
module Oracles.ModuleFiles (moduleFiles, haskellModuleFiles, moduleFilesOracle) where
import Base hiding (exe)
import Distribution.ModuleName
import Distribution.PackageDescription
import Distribution.PackageDescription.Parse
import Distribution.Verbosity
import GHC
import Oracles.PackageData
import Package hiding (library)
import Stage
import Settings.TargetDirectory
newtype ModuleFilesKey = ModuleFilesKey (Package, [FilePath])
deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
moduleFiles :: Stage -> Package -> Action [FilePath]
moduleFiles stage pkg = do
let path = targetPath stage pkg
modules <- fmap sort . pkgDataList $ Modules path
(found, _ :: [FilePath]) <- askOracle $ ModuleFilesKey (pkg, [])
let cmp (m1, _) m2 = compare m1 m2
foundFiles = map snd $ intersectOrd cmp found modules
return foundFiles
haskellModuleFiles :: Stage -> Package -> Action ([FilePath], [String])
haskellModuleFiles stage pkg = do
let path = targetPath stage pkg
autogen = path -/- "build/autogen"
modules <- fmap sort . pkgDataList $ Modules path
(found, missingMods) <- askOracle $ ModuleFilesKey (pkg, [autogen])
let cmp (m1, _) m2 = compare m1 m2
foundFiles = map snd $ intersectOrd cmp found modules
otherMods = map (replaceEq '/' '.' . dropExtension) otherFiles
(haskellFiles, otherFiles) = partition ("//*hs" ?==) foundFiles
return (haskellFiles, missingMods ++ otherMods)
extract :: Monoid a => Maybe (CondTree v c a) -> a
extract Nothing = mempty
extract (Just (CondNode leaf _ ifs)) = leaf <> mconcat (map f ifs)
where
f (_, t, mt) = extract (Just t) <> extract mt
-- Look up Haskell source directories and module names of a package
packageInfo :: Package -> Action ([FilePath], [ModuleName])
packageInfo pkg
| pkg == hp2ps = return (["."], [])
| otherwise = do
need [pkgCabalFile pkg]
pd <- liftIO . readPackageDescription silent $ pkgCabalFile pkg
let lib = extract $ condLibrary pd
exe = extract . Just . snd . head $ condExecutables pd
let (srcDirs, modules) = if lib /= mempty
then ( hsSourceDirs $ libBuildInfo lib, libModules lib)
else ( hsSourceDirs $ buildInfo exe
, [fromString . dropExtension $ modulePath exe]
++ exeModules exe)
return (if null srcDirs then ["."] else srcDirs, modules)
moduleFilesOracle :: Rules ()
moduleFilesOracle = do
answer <- newCache $ \(pkg, extraDirs) -> do
putOracle $ "Searching module files of package " ++ pkgName pkg ++ "..."
unless (null extraDirs) $ putOracle $ "Extra directory = " ++ show extraDirs
(srcDirs, modules) <- packageInfo pkg
let dirs = extraDirs ++ [ pkgPath pkg -/- dir | dir <- srcDirs ]
decodedPairs = sort $ map (splitFileName . toFilePath) modules
modDirFiles = map (bimap head sort . unzip)
. groupBy ((==) `on` fst) $ decodedPairs
result <- fmap concat . forM dirs $ \dir -> do
todo <- filterM (doesDirectoryExist . (dir -/-) . fst) modDirFiles
forM todo $ \(mDir, mFiles) -> do
let fullDir = dir -/- mDir
files <- getDirectoryFiles fullDir ["*"]
let noBoot = filter (not . (isSuffixOf "-boot")) files
cmp fe f = compare (dropExtension fe) f
found = intersectOrd cmp noBoot mFiles
return (map (fullDir -/-) found, (mDir, map dropExtension found))
let foundFiles = sort [ (encodeModule d f, f)
| (fs, (d, _)) <- result, f <- fs ]
foundPairs = [ (d, f) | (d, fs) <- map snd result, f <- fs ]
missingPairs = decodedPairs `minusOrd` sort foundPairs
missingMods = map (uncurry encodeModule) missingPairs
return (foundFiles, missingMods)
_ <- addOracle $ \(ModuleFilesKey query) -> answer query
return ()
......@@ -3,6 +3,7 @@ module Rules.Generate (generatePackageCode) where
import Expression
import GHC
import Oracles
import Oracles.ModuleFiles
import Rules.Actions
import Rules.Resources (Resources)
import Settings
......@@ -25,16 +26,14 @@ determineBuilder file = fmap fst $ find (\(_, e) -> e == ext) knownGenerators
generatePackageCode :: Resources -> PartialTarget -> Rules ()
generatePackageCode _ target @ (PartialTarget stage pkg) =
let path = targetPath stage pkg
packagePath = pkgPath pkg
buildPath = path -/- "build"
primopsTxt = targetPath stage compiler -/- "build/primops.txt"
platformH = targetPath stage compiler -/- "ghc_boot_platform.h"
generated f = (buildPath ++ "//*.hs") ?== f && not ("//autogen/*" ?== f)
in do
generated ?> \file -> do
dirs <- interpretPartial target $ getPkgDataList SrcDirs
files <- getDirectoryFiles "" $
[ packagePath -/- d ++ "//" ++ takeBaseName file <.> "*" | d <- dirs ]
let pattern = "//" ++ takeBaseName file <.> "*"
files <- fmap (filter (pattern ?==)) $ moduleFiles stage pkg
let gens = [ (f, b) | f <- files, Just b <- [determineBuilder f] ]
when (length gens /= 1) . putError $
"Exactly one generator expected for " ++ file
......
......@@ -3,12 +3,14 @@ module Rules.Oracles (oracleRules) where
import Base
import Oracles
import Oracles.ArgsHash
import Oracles.ModuleFiles
oracleRules :: Rules ()
oracleRules = do
argsHashOracle -- see Oracles.ArgsHash
configOracle -- see Oracles.Config
dependenciesOracle -- see Oracles.Dependencies
moduleFilesOracle -- see Oracles.ModuleFiles
packageDataOracle -- see Oracles.PackageData
packageDepsOracle -- see Oracles.PackageDeps
dependenciesOracle -- see Oracles.Dependencies
argsHashOracle -- see Oracles.ArgsHash
windowsRootOracle -- see Oracles.WindowsRoot
......@@ -4,11 +4,12 @@ module Settings (
module Settings.User,
module Settings.Ways,
getPkgData, getPkgDataList, programPath, isLibrary,
getPackagePath, getTargetDirectory, getTargetPath, getPackageSources,
getPackagePath, getTargetDirectory, getTargetPath, getPackageSources
) where
import Expression
import Oracles
import Oracles.ModuleFiles
import Settings.Packages
import Settings.TargetDirectory
import Settings.User
......@@ -32,53 +33,17 @@ getPkgDataList key = lift . pkgDataList . key =<< getTargetPath
programPath :: Stage -> Package -> Maybe FilePath
programPath = userProgramPath
-- Find all Haskell source files for the current target. TODO: simplify.
-- | Find all Haskell source files for the current target
getPackageSources :: Expr [FilePath]
getPackageSources = do
path <- getTargetPath
packagePath <- getPackagePath
srcDirs <- getPkgDataList SrcDirs
stage <- getStage
pkg <- getPackage
path <- getTargetPath
let buildPath = path -/- "build"
autogen = buildPath -/- "autogen"
dirs = autogen : map (packagePath -/-) srcDirs
(foundSources, missingSources) <- findModuleFiles dirs "*hs"
(found, missingMods) <- lift $ haskellModuleFiles stage pkg
-- Generated source files live in buildPath and have extension "hs"...
let generatedSources = [ buildPath -/- s <.> "hs" | s <- missingSources ]
-- ...except that GHC/Prim.hs lives in autogen. TODO: fix?
let generated = [ buildPath -/- (replaceEq '.' '/' m) <.> "hs" | m <- missingMods ]
-- ...except that GHC/Prim.hs lives in autogen. TODO: fix the inconsistency?
fixGhcPrim = replaceEq (buildPath -/- "GHC/Prim.hs") (autogen -/- "GHC/Prim.hs")
return $ foundSources ++ fixGhcPrim generatedSources
-- findModuleFiles scans a list of given directories and finds files matching a
-- given pattern (e.g., "*hs") that correspond to modules of the currently built
-- package. Missing module files are returned in a separate list. The returned
-- pair contains the following:
-- * a list of found module files, with paths being relative to one of given
-- directories, e.g. "codeGen/CodeGen/Platform.hs" for the compiler package.
-- * a list of module files that have not been found, with paths being relative
-- to the module directory, e.g. "CodeGen/Platform", and with no extension.
findModuleFiles :: [FilePath] -> FilePattern -> Expr ([FilePath], [FilePath])
findModuleFiles dirs pattern = do
modules <- getPkgDataList Modules
let decodedMods = sort . map decodeModule $ modules
modDirFiles = map (bimap head sort . unzip)
. groupBy ((==) `on` fst) $ decodedMods
result <- lift . fmap concat . forM dirs $ \dir -> do
todo <- filterM (doesDirectoryExist . (dir -/-) . fst) modDirFiles
forM todo $ \(mDir, mFiles) -> do
let fullDir = dir -/- mDir
files <- getDirectoryFiles fullDir [pattern]
let cmp fe f = compare (dropExtension fe) f
found = intersectOrd cmp files mFiles
return (map (fullDir -/-) found, (mDir, map dropExtension found))
let foundFiles = concatMap fst result
foundMods = [ (d, f) | (d, fs) <- map snd result, f <- fs ]
missingMods = decodedMods `minusOrd` sort foundMods
missingFiles = map (uncurry (-/-)) missingMods
return (foundFiles, missingFiles)
return $ found ++ fixGhcPrim generated
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment