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

src/Oracles/ModuleFiles.hs

+{-# 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 ()

src/Rules/Generate.hs

@@ -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

src/Rules/Oracles.hs

@@ -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

src/Settings.hs

@@ -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