Add findGenerator, refactor Oracles.ModuleFiles.

See #210.

src/Oracles/ModuleFiles.hs

@@ -1,8 +1,10 @@
-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, LambdaCase #-}
 module Oracles.ModuleFiles (
-    moduleFiles, haskellSources, moduleFilesOracle, findModuleFiles
+    findGenerator, haskellSources, moduleFilesOracle, findModuleFiles
     ) where
 
+import qualified Data.HashMap.Strict as Map
+
 import Base
 import Context
 import Expression
@@ -12,40 +14,51 @@ import Settings.Paths
 newtype ModuleFilesKey = ModuleFilesKey ([FilePath], [String])
     deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
 
-moduleFiles :: Context -> Action [FilePath]
-moduleFiles context @ Context {..} = do
-    let path    = contextPath context
-        autogen = path -/- "build/autogen"
-    srcDirs <- fmap sort . pkgDataList $ SrcDirs path
-    modules <- fmap sort . pkgDataList $ Modules path
-    let dirs = [ pkgPath package -/- dir | dir <- srcDirs ]
-    catMaybes <$> findModuleFiles (autogen : dirs) modules
+newtype Generator = Generator (Context, FilePath)
+    deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
 
-haskellModuleFiles :: Context -> Action ([FilePath], [String])
-haskellModuleFiles context @ Context {..} = do
-    let path        = contextPath context
-        autogen     = path -/- "build/autogen"
-        dropPkgPath = drop $ length (pkgPath package) + 1
-    srcDirs <- fmap sort . pkgDataList $ SrcDirs path
-    modules <- fmap sort . pkgDataList $ Modules path
-    let dirs = [ pkgPath package -/- dir | dir <- srcDirs ]
-    found <- findModuleFiles (autogen : dirs) modules
-    let missingMods    = map fst . filter (isNothing . snd) $ zip modules found
-        otherFileToMod = replaceEq '/' '.' . dropExtension . dropPkgPath
-        (haskellFiles, otherFiles) = partition ("//*hs" ?==) $ catMaybes found
-    return (haskellFiles, missingMods ++ map otherFileToMod otherFiles)
+-- The following generators and corresponding source extensions are supported:
+determineBuilder :: FilePath -> Maybe Builder
+determineBuilder file = case takeExtension file of
+    ".x"   -> Just Alex
+    ".y"   -> Just Happy
+    ".ly"  -> Just Happy
+    ".hsc" -> Just Hsc2Hs
+    _      -> Nothing
 
--- | Find all Haskell source files for the current context
+-- | 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 = askOracle $ Generator (context, file)
+
+-- | Find all Haskell source files for a given 'Context'.
 haskellSources :: Context -> Action [FilePath]
 haskellSources context = do
-    let buildPath = contextPath context -/- "build"
-        autogen   = buildPath -/- "autogen"
-    (found, missingMods) <- haskellModuleFiles context
-    -- Generated source files live in buildPath and have extension "hs"...
-    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 $ found ++ fixGhcPrim generated
+    let autogen = contextPath context -/- "build/autogen"
+    -- Generated source files live in build/ and have extension "hs", except
+    -- that GHC/Prim.hs lives in build/autogen/. TODO: fix the inconsistency?
+    let modFile ("GHC.Prim", _) = autogen -/- "GHC/Prim.hs"
+        modFile (m, Nothing   ) = generatedFile context m
+        modFile (m, Just file ) | "//*hs" ?== file = file
+                                | otherwise        = modFile (m, Nothing)
+    map modFile <$> contextFiles context
+
+generatedFile :: Context -> String -> FilePath
+generatedFile context moduleName =
+    contextPath context -/- "build" -/- replaceEq '.' '/' moduleName <.> "hs"
+
+contextFiles :: Context -> Action [(String, Maybe FilePath)]
+contextFiles context @ Context {..} = do
+    let path = contextPath context
+    srcDirs <- fmap sort . pkgDataList $ SrcDirs path
+    modules <- fmap sort . pkgDataList $ Modules path
+    let dirs = [ pkgPath package -/- dir | dir <- srcDirs ]
+    zip modules <$> findModuleFiles (path -/- "build/autogen" : dirs) modules
 
 -- | This is an important oracle whose role is to find and cache module source
 -- files. More specifically, it takes a list of directories @dirs@ and a sorted
@@ -62,8 +75,8 @@ findModuleFiles :: [FilePath] -> [String] -> Action [Maybe FilePath]
 findModuleFiles dirs modules = askOracle $ ModuleFilesKey (dirs, modules)
 
 moduleFilesOracle :: Rules ()
-moduleFilesOracle = void $
-    addOracle $ \(ModuleFilesKey (dirs, modules)) -> do
+moduleFilesOracle = void $ do
+    void $ addOracle $ \(ModuleFilesKey (dirs, modules)) -> do
         let decodedPairs = map decodeModule modules
             modDirFiles  = map (bimap head id . unzip)
                          . groupBy ((==) `on` fst) $ decodedPairs
@@ -83,10 +96,15 @@ moduleFilesOracle = void $
 
         unless (null multi) $ do
             let (m, f1, f2) = head multi
-            errorMultipleSources m f1 f2
+            putError $ "Module " ++ m ++ " has more than one source file: "
+                ++ f1 ++ " and " ++ f2 ++ "."
 
         return $ lookupAll modules pairs
 
-errorMultipleSources :: String -> FilePath -> FilePath -> Action a
-errorMultipleSources m f1 f2 = putError $ "Module " ++ m ++
-    " has more than one source file: " ++ f1 ++ " and " ++ f2 ++ "."
+    gens <- newCache $ \context -> do
+        files <- contextFiles context
+        return $ Map.fromList [ (generatedFile context modName, (src, builder))
+                              | (modName, Just src) <- files
+                              , let Just builder = determineBuilder src ]
+
+    addOracle $ \(Generator (context, file)) -> Map.lookup file <$> gens context

src/Rules/Generate.hs

@@ -98,18 +98,6 @@ generatedDependencies stage pkg
     | stage == Stage0   = includesDependencies
     | otherwise         = []
 
--- The following generators and corresponding source extensions are supported:
-knownGenerators :: [ (Builder, String) ]
-knownGenerators =  [ (Alex  , ".x"  )
-                   , (Happy , ".y"  )
-                   , (Happy , ".ly" )
-                   , (Hsc2Hs, ".hsc") ]
-
-determineBuilder :: FilePath -> Maybe Builder
-determineBuilder file = fmap fst $ find (\(_, e) -> e == ext) knownGenerators
-  where
-    ext = takeExtension file
-
 generate :: FilePath -> Context -> Expr String -> Action ()
 generate file context expr = do
     contents <- interpretInContext context expr
@@ -119,19 +107,14 @@ generate file context expr = do
 generatePackageCode :: Context -> Rules ()
 generatePackageCode context @ (Context stage pkg _) =
     let buildPath   = contextPath context -/- "build"
-        dropBuild   = drop (length buildPath + 1)
         generated f = (buildPath ++ "//*.hs") ?== f && not ("//autogen/*" ?== f)
         file <~ gen = generate file context gen
     in do
         generated ?> \file -> do
-            let srcFile = dropBuild file
-                pattern = "//" ++ srcFile -<.> "*"
-            files <- fmap (filter (pattern ?==)) $ moduleFiles context
-            let gens = [ (f, b) | f <- files, Just b <- [determineBuilder f] ]
-            when (length gens /= 1) . putError $
-                "Exactly one generator expected for " ++ file
-                ++ " (found: " ++ show gens ++ ")."
-            let (src, builder) = head gens
+            maybeValue <- findGenerator context file
+            (src, builder) <- case maybeValue of
+                Nothing    -> putError $ "No generator for " ++ file ++ "."
+                Just value -> return value
             need [src]
             build $ Target context builder [src] [file]
             let srcBoot = src -<.> "hs-boot"