Commit 49419bc5 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Refactor oracles, add comments.

parent 03f90e74
......@@ -11,9 +11,6 @@ import Oracles.Base
import Oracles.Flag
import Oracles.Setting
import GHC.Generics
import Development.Shake
import Development.Shake.Classes
import Development.Shake.FilePath
-- A Builder is an external command invoked in separate process using Shake.cmd
--
......
......@@ -20,7 +20,6 @@ import Oracles.Base
import Data.List
import Data.Monoid
import Control.Monad.Reader hiding (liftIO)
import Development.Shake
-- Expr a is a computation that produces a value of type Action a and can read
-- parameters of the current build Target.
......
import Rules
import Config
import Development.Shake
main = shakeArgs shakeOptions{shakeFiles="_build/"} $ do
......
module Oracles (
module Oracles.Base,
configOracle, packageDataOracle, dependencyOracle
) where
import Util
import Config
import Oracles.Base
import Oracles.PackageData
import Oracles.DependencyList
import Data.List
import Data.Function
import qualified Data.HashMap.Strict as M
import Control.Applicative
import Control.Monad.Extra
import Development.Shake
import Development.Shake.Util
import Development.Shake.Config
import Development.Shake.FilePath
-- Oracle for configuration files
configOracle :: Rules ()
configOracle = do
let configFile = cfgPath </> "system.config"
cfg <- newCache $ \() -> do
unlessM (doesFileExist $ configFile <.> "in") $
redError_ $ "\nConfiguration file '" ++ (configFile <.> "in")
++ "' is missing; unwilling to proceed."
need [configFile]
putOracle $ "Reading " ++ unifyPath configFile ++ "..."
liftIO $ readConfigFile configFile
addOracle $ \(ConfigKey key) -> M.lookup key <$> cfg ()
return ()
-- Oracle for 'package-data.mk' files
packageDataOracle :: Rules ()
packageDataOracle = do
pkgData <- newCache $ \file -> do
need [file]
putOracle $ "Reading " ++ file ++ "..."
liftIO $ readConfigFile file
addOracle $ \(PackageDataKey (file, key)) ->
M.lookup key <$> pkgData (unifyPath file)
return ()
bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
bimap f g (x, y) = (f x, g y)
-- Oracle for 'path/dist/*.deps' files
dependencyOracle :: Rules ()
dependencyOracle = do
deps <- newCache $ \file -> do
need [file]
putOracle $ "Reading " ++ file ++ "..."
contents <- parseMakefile <$> (liftIO $ readFile file)
return $ M.fromList
$ map (bimap unifyPath (map unifyPath))
$ map (bimap head concat . unzip)
$ groupBy ((==) `on` fst)
$ sortBy (compare `on` fst) contents
addOracle $ \(DependencyListKey (file, obj)) ->
M.lookup (unifyPath obj) <$> deps (unifyPath file)
return ()
-- Make oracle's output more distinguishable
putOracle :: String -> Action ()
putOracle = putColoured Blue
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Oracles.ArgsHash (
ArgsHashKey (..), askArgsHash, argsHashOracle
askArgsHash, argsHashOracle
) where
import Expression
......@@ -11,8 +11,12 @@ import Development.Shake
import Development.Shake.Classes
newtype ArgsHashKey = ArgsHashKey FullTarget
deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
-- This is an action that given a full target determines the corresponding
-- argument list and computes its hash. The resulting value is tracked in a
-- Shake oracle, hence initiating rebuilts when the hash is changed (a hash
-- change indicates changes in the build system).
askArgsHash :: FullTarget -> Action Int
askArgsHash = askOracle . ArgsHashKey
......
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Oracles.Base (
ConfigKey (..),
askConfigWithDefault, askConfig
module Development.Shake,
module Development.Shake.Util,
module Development.Shake.Config,
module Development.Shake.Classes,
module Development.Shake.FilePath,
askConfigWithDefault, askConfig, configOracle,
configPath,
putOracle
) where
import Util
import Control.Applicative
import Control.Monad.Extra
import Development.Shake
import Development.Shake.Util
import Development.Shake.Config
import Development.Shake.Classes
import Development.Shake.FilePath
import qualified Data.HashMap.Strict as Map
configPath :: FilePath
configPath = "shake" </> "cfg"
newtype ConfigKey = ConfigKey String
deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
......@@ -20,5 +35,23 @@ askConfigWithDefault key defaultAction = do
Nothing -> defaultAction
askConfig :: String -> Action String
askConfig key = askConfigWithDefault key $
redError $ "Cannot find key '" ++ key ++ "' in configuration files."
askConfig key = askConfigWithDefault key . redError
$ "Cannot find key '" ++ key ++ "' in configuration files."
-- Oracle for configuration files
configOracle :: Rules ()
configOracle = do
let configFile = configPath </> "system.config"
cfg <- newCache $ \() -> do
unlessM (doesFileExist $ configFile <.> "in") $
redError_ $ "\nConfiguration file '" ++ (configFile <.> "in")
++ "' is missing; unwilling to proceed."
need [configFile]
putOracle $ "Reading " ++ unifyPath configFile ++ "..."
liftIO $ readConfigFile configFile
addOracle $ \(ConfigKey key) -> Map.lookup key <$> cfg ()
return ()
-- Make oracle's output more distinguishable
putOracle :: String -> Action ()
putOracle = putColoured Blue
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Oracles.DependencyList (
DependencyList (..),
DependencyListKey (..),
dependencyList
dependencyList,
dependencyListOracle
) where
import Util
import Oracles.Base
import Data.List
import Data.Maybe
import Development.Shake
import Development.Shake.Classes
data DependencyList = DependencyList FilePath FilePath
import Data.Function
import qualified Data.HashMap.Strict as Map
import Control.Applicative
newtype DependencyListKey = DependencyListKey (FilePath, FilePath)
deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
-- dependencyList depFile objFile is an action that looks up dependencies of an
-- object file (objFile) in a generated dependecy file (depFile).
dependencyList :: FilePath -> FilePath -> Action [FilePath]
dependencyList depFile objFile = do
res <- askOracle $ DependencyListKey (depFile, objFile)
return $ fromMaybe [] res
-- Oracle for 'path/dist/*.deps' files
dependencyListOracle :: Rules ()
dependencyListOracle = do
deps <- newCache $ \file -> do
need [file]
putOracle $ "Reading " ++ file ++ "..."
contents <- parseMakefile <$> (liftIO $ readFile file)
return $ Map.fromList
$ map (bimap unifyPath (map unifyPath))
$ map (bimap head concat . unzip)
$ groupBy ((==) `on` fst)
$ sortBy (compare `on` fst) contents
addOracle $ \(DependencyListKey (file, obj)) ->
Map.lookup (unifyPath obj) <$> deps (unifyPath file)
return ()
dependencyList :: DependencyList -> Action [FilePath]
dependencyList (DependencyList file obj) = do
res <- askOracle $ DependencyListKey (file, obj)
return $ fromMaybe [] res
bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
bimap f g (x, y) = (f x, g y)
......@@ -5,7 +5,6 @@ module Oracles.Flag (
import Util
import Oracles.Base
import Development.Shake
data Flag = LaxDeps
| DynamicGhcPrograms
......
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Oracles.PackageData (
PackageData (..), PackageDataMulti (..),
PackageDataKey (..),
pkgData, pkgDataMulti
PackageData (..), PackageDataList (..),
pkgData, pkgDataList, packageDataOracle
) where
import Util
import Oracles.Base
import Data.List
import Data.Maybe
import Development.Shake
import Development.Shake.Classes
import Development.Shake.FilePath
import Control.Applicative
import qualified Data.HashMap.Strict as Map
-- For each (PackageData path) the file 'path/package-data.mk' contains
-- a line of the form 'path_VERSION = 1.2.3.4'.
-- pkgData $ PackageData path is an action that consults the file and
-- returns "1.2.3.4".
--
-- PackageDataMulti is used for multiple string options separated by spaces,
-- PackageDataList is used for multiple string options separated by spaces,
-- such as 'path_MODULES = Data.Array Data.Array.Base ...'.
-- pkgMultiData Modules therefore returns ["Data.Array", "Data.Array.Base", ...]
-- pkgListData Modules therefore returns ["Data.Array", "Data.Array.Base", ...]
data PackageData = Version FilePath
| PackageKey FilePath
| Synopsis FilePath
data PackageDataMulti = Modules FilePath
| SrcDirs FilePath
| IncludeDirs FilePath
| Deps FilePath
| DepKeys FilePath
| DepNames FilePath
| CppArgs FilePath
| HsArgs FilePath
| CcArgs FilePath
| CSrcs FilePath
| DepIncludeDirs FilePath
data PackageDataList = Modules FilePath
| SrcDirs FilePath
| IncludeDirs FilePath
| Deps FilePath
| DepKeys FilePath
| DepNames FilePath
| CppArgs FilePath
| HsArgs FilePath
| CcArgs FilePath
| CSrcs FilePath
| DepIncludeDirs FilePath
newtype PackageDataKey = PackageDataKey (FilePath, String)
deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
askPackageData :: FilePath -> String -> Action String
askPackageData path key = do
......@@ -61,8 +59,8 @@ pkgData packageData = do
return $ fromMaybe
(error $ "No key '" ++ key ++ "' in " ++ unifyPath pkgData ++ ".") res
pkgDataMulti :: PackageDataMulti -> Action [String]
pkgDataMulti packageData = do
pkgDataList :: PackageDataList -> Action [String]
pkgDataList packageData = do
let (key, path, defaultValue) = case packageData of
Modules path -> ("MODULES" , path, "" )
SrcDirs path -> ("HS_SRC_DIRS" , path, ".")
......@@ -84,3 +82,14 @@ pkgDataMulti packageData = do
++ unifyPath pkgData ++ "."
Just "" -> defaultValue
Just value -> value
-- Oracle for 'package-data.mk' files
packageDataOracle :: Rules ()
packageDataOracle = do
pkgData <- newCache $ \file -> do
need [file]
putOracle $ "Reading " ++ file ++ "..."
liftIO $ readConfigFile file
addOracle $ \(PackageDataKey (file, key)) ->
Map.lookup key <$> pkgData (unifyPath file)
return ()
module Oracles.Setting (
Setting (..), SettingMulti (..),
setting, settingMulti,
Setting (..), SettingList (..),
setting, settingList,
windowsHost
) where
import Stage
import Oracles.Base
import Development.Shake
-- Each Setting comes from the system.config file, e.g. 'target-os = mingw32'.
-- setting TargetOs looks up the config file and returns "mingw32".
--
-- SettingMulti is used for multiple string values separated by spaces, such
-- SettingList is used for multiple string values separated by spaces, such
-- as 'src-hc-args = -H32m -O'.
-- settingMulti SrcHcArgs therefore returns a list of strings ["-H32", "-O"].
-- settingList SrcHcArgs therefore returns a list of strings ["-H32", "-O"].
data Setting = TargetOs
| TargetArch
| TargetPlatformFull
......@@ -22,18 +21,18 @@ data Setting = TargetOs
| ProjectVersion
| GhcSourcePath
data SettingMulti = SrcHcArgs
| ConfCcArgs Stage
| ConfGccLinkerArgs Stage
| ConfLdLinkerArgs Stage
| ConfCppArgs Stage
| IconvIncludeDirs
| IconvLibDirs
| GmpIncludeDirs
| GmpLibDirs
data SettingList = SrcHcArgs
| ConfCcArgs Stage
| ConfGccLinkerArgs Stage
| ConfLdLinkerArgs Stage
| ConfCppArgs Stage
| IconvIncludeDirs
| IconvLibDirs
| GmpIncludeDirs
| GmpLibDirs
setting :: Setting -> Action String
setting s = askConfig $ case s of
setting key = askConfig $ case key of
TargetOs -> "target-os"
TargetArch -> "target-arch"
TargetPlatformFull -> "target-platform-full"
......@@ -42,19 +41,17 @@ setting s = askConfig $ case s of
ProjectVersion -> "project-version"
GhcSourcePath -> "ghc-source-path"
settingMulti :: SettingMulti -> Action [String]
settingMulti s = fmap words $ askConfig $ case s of
settingList :: SettingList -> Action [String]
settingList key = fmap words $ askConfig $ case key of
SrcHcArgs -> "src-hc-args"
ConfCcArgs stage -> "conf-cc-args" ++ showStage stage
ConfCppArgs stage -> "conf-cpp-args" ++ showStage stage
ConfGccLinkerArgs stage -> "conf-gcc-linker-args" ++ showStage stage
ConfLdLinkerArgs stage -> "conf-ld-linker-args" ++ showStage stage
ConfCcArgs stage -> "conf-cc-args-stage" ++ show stage
ConfCppArgs stage -> "conf-cpp-args-stage" ++ show stage
ConfGccLinkerArgs stage -> "conf-gcc-linker-args-stage" ++ show stage
ConfLdLinkerArgs stage -> "conf-ld-linker-args-stage" ++ show stage
IconvIncludeDirs -> "iconv-include-dirs"
IconvLibDirs -> "iconv-lib-dirs"
GmpIncludeDirs -> "gmp-include-dirs"
GmpLibDirs -> "gmp-lib-dirs"
where
showStage = ("-stage" ++) . show
windowsHost :: Action Bool
windowsHost = do
......
module Rules (
generateTargets, packageRules, oracleRules,
module Rules.Package,
module Rules.Config,
) where
import Stage
import Expression
import Rules.Config
import Rules.Package
import Rules.Oracles
import Settings.Packages
......
module Config (
autoconfRules, configureRules, cfgPath
module Rules.Config (
autoconfRules, configureRules
) where
import Util
import Development.Shake
import Development.Shake.FilePath
cfgPath :: FilePath
cfgPath = "shake" </> "cfg"
import Oracles.Base
autoconfRules :: Rules ()
autoconfRules = do
"configure" %> \out -> do
copyFile' (cfgPath </> "configure.ac") "configure.ac"
copyFile' (configPath </> "configure.ac") "configure.ac"
putColoured White $ "Running autoconf..."
cmd "bash autoconf" -- TODO: get rid of 'bash'
configureRules :: Rules ()
configureRules = do
cfgPath </> "system.config" %> \out -> do
need [cfgPath </> "system.config.in", "configure"]
configPath </> "system.config" %> \out -> do
need [configPath </> "system.config.in", "configure"]
putColoured White "Running configure..."
cmd "bash configure" -- TODO: get rid of 'bash'
......@@ -2,11 +2,12 @@ module Rules.Oracles (
oracleRules
) where
import Oracles
import Oracles.Base
import Oracles.ArgsHash
import Oracles.PackageData
import Oracles.DependencyList
import Data.Monoid
import Development.Shake
oracleRules :: Rules ()
oracleRules =
configOracle <> packageDataOracle <> dependencyOracle <> argsHashOracle
configOracle <> packageDataOracle <> dependencyListOracle <> argsHashOracle
......@@ -17,8 +17,6 @@ import Settings.Packages
import Settings.TargetDirectory
import Data.List
import Control.Applicative
import Development.Shake
import Development.Shake.FilePath
cabalArgs :: Args
cabalArgs = builder GhcCabal ? do
......
......@@ -16,7 +16,6 @@ import Stage
import Builder
import Oracles.Base
import Expression
import Development.Shake
-- A single argument.
arg :: String -> Args
......
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