Implement install_docs (#442)
[hadrian.git] / src / Settings.hs
index d16c5cd..e40f20d 100644 (file)
@@ -1,88 +1,68 @@
 module Settings (
-    module Settings.Packages,
-    module Settings.TargetDirectory,
-    module Settings.User,
-    module Settings.Ways,
-    getPkgData, getPkgDataList, programPath, isLibrary,
-    getPackagePath, getTargetDirectory, getTargetPath, getPackageSources,
+    getArgs, getLibraryWays, getRtsWays, flavour, knownPackages,
+    findPackageByName, getPkgData, getPkgDataList, isLibrary, stagePackages,
+    programContext, integerLibraryName, getDestDir
     ) where
 
+import CommandLine
 import Expression
-import Oracles
-import Settings.Packages
-import Settings.TargetDirectory
-import Settings.User
-import Settings.Ways
-
-getPackagePath :: Expr FilePath
-getPackagePath = liftM pkgPath getPackage
-
-getTargetDirectory :: Expr FilePath
-getTargetDirectory = liftM2 targetDirectory getStage getPackage
-
-getTargetPath :: Expr FilePath
-getTargetPath = liftM2 targetPath getStage getPackage
-
-getPkgData :: (FilePath -> PackageData) -> Expr String
-getPkgData key = lift . pkgData . key =<< getTargetPath
-
-getPkgDataList :: (FilePath -> PackageDataList) -> Expr [String]
-getPkgDataList key = lift . pkgDataList . key =<< getTargetPath
-
-programPath :: Stage -> Package -> Maybe FilePath
-programPath = userProgramPath
-
-isLibrary :: Package -> Bool
-isLibrary pkg = programPath Stage0 pkg == Nothing
-
--- Find all Haskell source files for the current target. TODO: simplify.
-getPackageSources :: Expr [FilePath]
-getPackageSources = do
-    path        <- getTargetPath
-    packagePath <- getPackagePath
-    srcDirs     <- getPkgDataList SrcDirs
-
-    let buildPath = path -/- "build"
-        autogen   = buildPath -/- "autogen"
-        dirs      = autogen : map (packagePath -/-) srcDirs
-
-    (foundSources, missingSources) <- findModuleFiles dirs "*hs"
-
-    -- 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?
-        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 extension 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 extension = do
-    modules <- getPkgDataList Modules
-    let decodedMods    = sort . map decodeModule $ modules
-        modDirFiles    = map (bimap head sort . unzip)
-                       . groupBy ((==) `on` fst) $ decodedMods
-        matchExtension = (?==) ("*" <.> extension)
-
-    result <- lift . fmap concat . forM dirs $ \dir -> do
-        todo <- filterM (doesDirectoryExist . (dir -/-) . fst) modDirFiles
-        forM todo $ \(mDir, mFiles) -> do
-            let fullDir = dir -/- mDir
-            files <- fmap (filter matchExtension) $ getDirectoryContents fullDir
-            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)
+import Flavour
+import {-# SOURCE #-} Settings.Default
+import Settings.Flavours.Development
+import Settings.Flavours.Performance
+import Settings.Flavours.Profiled
+import Settings.Flavours.Quick
+import Settings.Flavours.Quickest
+import Settings.Flavours.QuickCross
+import UserSettings
+
+getArgs :: Args
+getArgs = expr flavour >>= args
+
+getLibraryWays :: Ways
+getLibraryWays = expr flavour >>= libraryWays
+
+getRtsWays :: Ways
+getRtsWays = expr flavour >>= rtsWays
+
+stagePackages :: Stage -> Action [Package]
+stagePackages stage = do
+    f <- flavour
+    packages f stage
+
+hadrianFlavours :: [Flavour]
+hadrianFlavours =
+    [ defaultFlavour, developmentFlavour Stage1, developmentFlavour Stage2
+    , performanceFlavour, profiledFlavour, quickFlavour, quickestFlavour
+    , quickCrossFlavour ]
+
+flavour :: Action Flavour
+flavour = do
+    flavourName <- fromMaybe "default" <$> cmdFlavour
+    let unknownFlavour = error $ "Unknown build flavour: " ++ flavourName
+        flavours       = hadrianFlavours ++ userFlavours
+    return $ fromMaybe unknownFlavour $ find ((== flavourName) . name) flavours
+
+integerLibraryName :: Action String
+integerLibraryName = pkgName <$> (integerLibrary =<< flavour)
+
+programContext :: Stage -> Package -> Action Context
+programContext stage pkg = do
+    profiled <- ghcProfiled <$> flavour
+    return $ if pkg == ghc && profiled && stage > Stage0
+             then Context stage pkg profiling
+             else vanillaContext stage pkg
+
+-- TODO: switch to Set Package as the order of packages should not matter?
+-- Otherwise we have to keep remembering to sort packages from time to time.
+knownPackages :: [Package]
+knownPackages = sort $ ghcPackages ++ userPackages
+
+-- TODO: Speed up? Switch to Set?
+-- Note: this is slow but we keep it simple as there are just ~50 packages
+findPackageByName :: PackageName -> Maybe Package
+findPackageByName name = find (\pkg -> pkgName pkg == name) knownPackages
+
+-- | Install's DESTDIR setting.
+getDestDir :: Action FilePath
+getDestDir = fromMaybe "" <$> cmdInstallDestDir