.bat file tidy up plus shake-0.16 compatibility (#392)
[hadrian.git] / src / Oracles / ModuleFiles.hs
index 73ec6eb..5bf970a 100644 (file)
-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, LambdaCase #-}
+{-# LANGUAGE TypeFamilies #-}
 module Oracles.ModuleFiles (
 module Oracles.ModuleFiles (
-    findGenerator, haskellSources, moduleFilesOracle, findModuleFiles
+    decodeModule, encodeModule, findGenerator, hsSources, hsObjects, moduleFilesOracle
     ) where
 
 import qualified Data.HashMap.Strict as Map
 
 import Base
 import Context
     ) where
 
 import qualified Data.HashMap.Strict as Map
 
 import Base
 import Context
-import Expression
+import GHC
 import Oracles.PackageData
 import Oracles.PackageData
-import Settings.Paths
 
 
-newtype ModuleFilesKey = ModuleFilesKey ([FilePath], [String])
-    deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
+newtype ModuleFiles = ModuleFiles (Stage, Package)
+    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult ModuleFiles = [Maybe FilePath]
 
 
-newtype Generator = Generator (Context, FilePath)
-    deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
+newtype Generator = Generator (Stage, Package, FilePath)
+    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult Generator = Maybe FilePath
 
 
--- The following generators and corresponding source extensions are supported:
+-- | 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 :: [(String, Builder)]
+otherExtensions = [ (".x"  , Alex  )
+                  , (".y"  , Happy )
+                  , (".ly" , Happy )
+                  , (".hsc", Hsc2Hs) ]
+
+-- | We match the following file patterns when looking for module files.
+moduleFilePatterns :: [FilePattern]
+moduleFilePatterns = map ("*" ++) $ haskellExtensions ++ map fst otherExtensions
+
+-- | Given a FilePath determine the corresponding builder.
 determineBuilder :: FilePath -> Maybe Builder
 determineBuilder :: FilePath -> Maybe Builder
-determineBuilder file = case takeExtension file of
-    ".x"   -> Just Alex
-    ".y"   -> Just Happy
-    ".ly"  -> Just Happy
-    ".hsc" -> Just Hsc2Hs
-    _      -> Nothing
+determineBuilder file = lookup (takeExtension file) otherExtensions
+
+-- | Given a module name extract the directory and file name, e.g.:
+--
+-- > decodeModule "Data.Functor.Identity" == ("Data/Functor", "Identity")
+-- > decodeModule "Prelude"               == ("", "Prelude")
+decodeModule :: String -> (FilePath, String)
+decodeModule modName = (intercalate "/" (init xs), last xs)
+  where
+    xs = words $ replaceEq '.' ' ' modName
+
+-- | 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 -> String
+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)
 
 -- | Find the generator for a given 'Context' and a source file. For example:
 -- findGenerator (Context Stage1 compiler vanilla)
---               ".build/stage1/compiler/build/Lexer.hs"
+--               "_build/stage1/compiler/build/Lexer.hs"
 -- == Just ("compiler/parser/Lexer.x", Alex)
 -- findGenerator (Context Stage1 base vanilla)
 -- == Just ("compiler/parser/Lexer.x", Alex)
 -- findGenerator (Context Stage1 base vanilla)
---               ".build/stage1/base/build/Prelude.hs"
+--               "_build/stage1/base/build/Prelude.hs"
 -- == Nothing
 findGenerator :: Context -> FilePath -> Action (Maybe (FilePath, Builder))
 -- == Nothing
 findGenerator :: Context -> FilePath -> Action (Maybe (FilePath, Builder))
-findGenerator context file = askOracle $ Generator (context, file)
+findGenerator Context {..} file = do
+    maybeSource <- askOracle $ Generator (stage, package, file)
+    return $ do
+        source  <- maybeSource
+        builder <- determineBuilder source
+        return (source, builder)
 
 -- | Find all Haskell source files for a given 'Context'.
 
 -- | Find all Haskell source files for a given 'Context'.
-haskellSources :: Context -> Action [FilePath]
-haskellSources context = do
-    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"
-
+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
+    path    <- buildPath context
+    modules <- pkgDataList (Modules path)
+    -- GHC.Prim module is only for documentation, we do not actually build it.
+    mapM (objectPath context . moduleSource) (filter (/= "GHC.Prim") modules)
+
+-- | Generated module files live in the 'Context' specific build directory.
+generatedFile :: Context -> String -> Action FilePath
+generatedFile context moduleName = do
+    path <- buildPath context
+    return $ path -/- moduleSource moduleName
+
+moduleSource :: String -> FilePath
+moduleSource moduleName = replaceEq '.' '/' moduleName <.> "hs"
+
+-- | Module files for a given 'Context'.
 contextFiles :: Context -> Action [(String, Maybe FilePath)]
 contextFiles :: Context -> Action [(String, Maybe FilePath)]
-contextFiles context @ Context {..} = do
-    let path = contextPath context
-    srcDirs <- fmap sort . pkgDataList $ SrcDirs path
+contextFiles context@Context {..} = do
+    path    <- buildPath context
     modules <- fmap sort . pkgDataList $ Modules path
     modules <- fmap sort . pkgDataList $ Modules path
-    let dirs = [ pkgPath package -/- dir | dir <- srcDirs ]
-    zip modules <$> findModuleFiles (path -/- "build/autogen" : dirs) modules
+    zip modules <$> askOracle (ModuleFiles (stage, package))
 
 -- | This is an important oracle whose role is to find and cache module source
 
 -- | 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
--- list of module names @modules@ as arguments, 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 the 'compiler' package given
--- @dirs = ["compiler/codeGen", "compiler/parser"]@, and
--- @modules = ["CodeGen.Platform.ARM", "Lexer", "Missing.Module"]@, it produces
--- @[Just "compiler/codeGen/CodeGen/Platform/ARM.hs",
--- Just "compiler/parser/Lexer.x", Nothing]@.
-findModuleFiles :: [FilePath] -> [String] -> Action [Maybe FilePath]
-findModuleFiles dirs modules = askOracle $ ModuleFilesKey (dirs, modules)
-
+-- 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
 moduleFilesOracle :: Rules ()
 moduleFilesOracle = void $ do
-    void $ addOracle $ \(ModuleFilesKey (dirs, modules)) -> do
-        let decodedPairs = map decodeModule modules
-            modDirFiles  = map (bimap head id . unzip)
-                         . groupBy ((==) `on` fst) $ decodedPairs
-
-        result <- fmap concat . forM dirs $ \dir -> do
+    void . addOracle $ \(ModuleFiles (stage, package)) -> do
+        let context = vanillaContext stage package
+        path    <- buildPath context
+        srcDirs <-             pkgDataList $ SrcDirs path
+        modules <- fmap sort . pkgDataList $ Modules path
+        autogen <- autogenPath context
+        let dirs = autogen : map (pkgPath package -/-) srcDirs
+            modDirFiles = groupSort $ map decodeModule modules
+        result <- concatForM dirs $ \dir -> do
             todo <- filterM (doesDirectoryExist . (dir -/-) . fst) modDirFiles
             forM todo $ \(mDir, mFiles) -> 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
+                let fullDir = unifyPath $ dir -/- mDir
+                files <- getDirectoryFiles fullDir moduleFilePatterns
+                let cmp fe f = compare (dropExtension fe) f
+                    found    = intersectOrd cmp files mFiles
                 return (map (fullDir -/-) found, mDir)
                 return (map (fullDir -/-) found, mDir)
-
         let pairs = sort [ (encodeModule d f, f) | (fs, d) <- result, f <- fs ]
             multi = [ (m, f1, f2) | (m, f1):(n, f2):_ <- tails pairs, m == n ]
         let pairs = sort [ (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
         unless (null multi) $ do
             let (m, f1, f2) = head multi
-            putError $ "Module " ++ m ++ " has more than one source file: "
+            error $ "Module " ++ m ++ " has more than one source file: "
                 ++ f1 ++ " and " ++ f2 ++ "."
                 ++ f1 ++ " and " ++ f2 ++ "."
-
         return $ lookupAll modules pairs
 
         return $ lookupAll modules pairs
 
-    gens <- newCache $ \context -> do
+    -- 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
         files <- contextFiles context
-        return $ Map.fromList [ (generatedFile context modName, (src, builder))
-                              | (modName, Just src) <- files
-                              , let Just builder = determineBuilder src ]
+        list  <- sequence [ (,src) <$> (generatedFile context modName)
+                          | (modName, Just src) <- files
+                          , takeExtension src `notElem` haskellExtensions ]
+        return $ Map.fromList list
 
 
-    addOracle $ \(Generator (context, file)) -> Map.lookup file <$> gens context
+    addOracle $ \(Generator (stage, package, file)) ->
+        Map.lookup file <$> generators (stage, package)