Commit 03f90e74 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Remove Base.hs, move Stage definition to Stage.hs.

parent 272f1005
{-# LANGUAGE DeriveGeneric, FlexibleInstances #-}
module Base (
module Development.Shake,
module Development.Shake.FilePath,
module Control.Applicative,
module Data.Function,
module Data.Monoid,
--module Data.List,
Stage (..),
Arg, ArgList,
ShowArg (..), ShowArgs (..),
productArgs, concatArgs
) where
import Development.Shake hiding ((*>))
import Development.Shake.FilePath
import Control.Applicative
import Data.Function
import Data.Monoid
import GHC.Generics
import Development.Shake.Classes
data Stage = Stage0 | Stage1 | Stage2 | Stage3 deriving (Eq, Enum, Generic)
instance Show Stage where
show = show . fromEnum
-- The returned string or list of strings is a part of an argument list
-- to be passed to a Builder
type Arg = Action String
type ArgList = Action [String]
instance Monoid a => Monoid (Action a) where
mempty = return mempty
mappend p q = mappend <$> p <*> q
class ShowArg a where
showArg :: a -> Arg
instance ShowArg String where
showArg = return
instance ShowArg a => ShowArg (Action a) where
showArg = (showArg =<<)
class ShowArgs a where
showArgs :: a -> ArgList
instance ShowArgs [String] where
showArgs = return
instance ShowArgs a => ShowArgs (Action a) where
showArgs = (showArgs =<<)
-- Generate a cross product collection of two argument collections
-- Example: productArgs ["-a", "-b"] "c" = args ["-a", "c", "-b", "c"]
productArgs :: (ShowArgs a, ShowArgs b) => a -> b -> ArgList
productArgs as bs = do
as' <- showArgs as
bs' <- showArgs bs
return $ concat $ sequence [as', bs']
-- Similar to productArgs but concat resulting arguments pairwise
-- Example: concatArgs ["-a", "-b"] "c" = args ["-ac", "-bc"]
concatArgs :: (ShowArgs a, ShowArgs b) => a -> b -> ArgList
concatArgs as bs = do
as' <- showArgs as
bs' <- showArgs bs
return $ map concat $ sequence [as', bs']
-- Instances for storing in the Shake database
instance Binary Stage
instance Hashable Stage
...@@ -4,14 +4,16 @@ module Builder ( ...@@ -4,14 +4,16 @@ module Builder (
Builder (..), builderKey, builderPath, needBuilder Builder (..), builderKey, builderPath, needBuilder
) where ) where
import Base
import Util import Util
import Stage
import Data.List import Data.List
import Oracles.Base import Oracles.Base
import Oracles.Flag import Oracles.Flag
import Oracles.Setting import Oracles.Setting
import GHC.Generics import GHC.Generics
import Development.Shake
import Development.Shake.Classes import Development.Shake.Classes
import Development.Shake.FilePath
-- A Builder is an external command invoked in separate process using Shake.cmd -- A Builder is an external command invoked in separate process using Shake.cmd
-- --
......
...@@ -2,8 +2,9 @@ module Config ( ...@@ -2,8 +2,9 @@ module Config (
autoconfRules, configureRules, cfgPath autoconfRules, configureRules, cfgPath
) where ) where
import Base
import Util import Util
import Development.Shake
import Development.Shake.FilePath
cfgPath :: FilePath cfgPath :: FilePath
cfgPath = "shake" </> "cfg" cfgPath = "shake" </> "cfg"
......
...@@ -12,14 +12,15 @@ module Expression ( ...@@ -12,14 +12,15 @@ module Expression (
) where ) where
import Way import Way
import Base import Stage
import Builder import Builder
import Package import Package
import Target import Target
import Data.List
import Oracles.Base import Oracles.Base
import Data.List
import Data.Monoid import Data.Monoid
import Control.Monad.Reader hiding (liftIO) 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 -- Expr a is a computation that produces a value of type Action a and can read
-- parameters of the current build Target. -- parameters of the current build Target.
......
import Base
import Rules import Rules
import Config import Config
import Development.Shake
main = shakeArgs shakeOptions{shakeFiles="_build/"} $ do main = shakeArgs shakeOptions{shakeFiles="_build/"} $ do
oracleRules -- see module Rules.Oracles oracleRules -- see module Rules.Oracles
......
...@@ -3,17 +3,20 @@ module Oracles ( ...@@ -3,17 +3,20 @@ module Oracles (
configOracle, packageDataOracle, dependencyOracle configOracle, packageDataOracle, dependencyOracle
) where ) where
import Development.Shake.Config
import Development.Shake.Util
import qualified Data.HashMap.Strict as M
import Base
import Util import Util
import Config import Config
import Control.Monad.Extra
import Oracles.Base import Oracles.Base
import Oracles.PackageData import Oracles.PackageData
import Oracles.DependencyList import Oracles.DependencyList
import Data.List 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 -- Oracle for configuration files
configOracle :: Rules () configOracle :: Rules ()
......
...@@ -4,9 +4,10 @@ module Oracles.ArgsHash ( ...@@ -4,9 +4,10 @@ module Oracles.ArgsHash (
ArgsHashKey (..), askArgsHash, argsHashOracle ArgsHashKey (..), askArgsHash, argsHashOracle
) where ) where
import Base
import Expression import Expression
import Settings.Args import Settings.Args
import Control.Applicative
import Development.Shake
import Development.Shake.Classes import Development.Shake.Classes
newtype ArgsHashKey = ArgsHashKey FullTarget newtype ArgsHashKey = ArgsHashKey FullTarget
......
...@@ -5,8 +5,8 @@ module Oracles.Base ( ...@@ -5,8 +5,8 @@ module Oracles.Base (
askConfigWithDefault, askConfig askConfigWithDefault, askConfig
) where ) where
import Base
import Util import Util
import Development.Shake
import Development.Shake.Classes import Development.Shake.Classes
newtype ConfigKey = ConfigKey String newtype ConfigKey = ConfigKey String
......
...@@ -2,19 +2,20 @@ ...@@ -2,19 +2,20 @@
module Oracles.DependencyList ( module Oracles.DependencyList (
DependencyList (..), DependencyList (..),
DependencyListKey (..) DependencyListKey (..),
dependencyList
) where ) where
import Development.Shake.Classes
import Base
import Data.Maybe import Data.Maybe
import Development.Shake
import Development.Shake.Classes
data DependencyList = DependencyList FilePath FilePath data DependencyList = DependencyList FilePath FilePath
newtype DependencyListKey = DependencyListKey (FilePath, FilePath) newtype DependencyListKey = DependencyListKey (FilePath, FilePath)
deriving (Show, Typeable, Eq, Hashable, Binary, NFData) deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
instance ShowArgs DependencyList where dependencyList :: DependencyList -> Action [FilePath]
showArgs (DependencyList file obj) = do dependencyList (DependencyList file obj) = do
res <- askOracle $ DependencyListKey (file, obj) res <- askOracle $ DependencyListKey (file, obj)
return $ fromMaybe [] res return $ fromMaybe [] res
...@@ -3,9 +3,9 @@ module Oracles.Flag ( ...@@ -3,9 +3,9 @@ module Oracles.Flag (
test test
) where ) where
import Base
import Util import Util
import Oracles.Base import Oracles.Base
import Development.Shake
data Flag = LaxDeps data Flag = LaxDeps
| DynamicGhcPrograms | DynamicGhcPrograms
......
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Oracles.PackageData ( module Oracles.PackageData (
PackageData (..), MultiPackageData (..), PackageData (..), PackageDataMulti (..),
PackageDataKey (..), askPackageData PackageDataKey (..),
pkgData, pkgDataMulti
) where ) where
import Development.Shake.Classes
import Base
import Util import Util
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Development.Shake
import Development.Shake.Classes
import Development.Shake.FilePath
-- For each (PackageData path) the file 'path/package-data.mk' contains -- For each (PackageData path) the file 'path/package-data.mk' contains
-- a line of the form 'path_VERSION = 1.2.3.4'. -- a line of the form 'path_VERSION = 1.2.3.4'.
-- (showArg $ PackageData path) is an action that consults the file and -- pkgData $ PackageData path is an action that consults the file and
-- returns "1.2.3.4". -- returns "1.2.3.4".
-- --
-- MultiPackageData is used for multiple string options separated by spaces, -- PackageDataMulti is used for multiple string options separated by spaces,
-- such as 'path_MODULES = Data.Array Data.Array.Base ...'. -- such as 'path_MODULES = Data.Array Data.Array.Base ...'.
-- (showArgs Modules) therefore returns ["Data.Array", "Data.Array.Base", ...]. -- pkgMultiData Modules therefore returns ["Data.Array", "Data.Array.Base", ...]
data PackageData = Version FilePath data PackageData = Version FilePath
| PackageKey FilePath | PackageKey FilePath
| Synopsis FilePath | Synopsis FilePath
data MultiPackageData = Modules FilePath data PackageDataMulti = Modules FilePath
| SrcDirs FilePath | SrcDirs FilePath
| IncludeDirs FilePath | IncludeDirs FilePath
| Deps FilePath | Deps FilePath
...@@ -47,41 +49,38 @@ askPackageData path key = do ...@@ -47,41 +49,38 @@ askPackageData path key = do
return $ fromMaybe return $ fromMaybe
(error $ "No key '" ++ key ++ "' in " ++ pkgData ++ ".") value (error $ "No key '" ++ key ++ "' in " ++ pkgData ++ ".") value
-- TODO: remove pkgData :: PackageData -> Action String
instance ShowArg PackageData where pkgData packageData = do
showArg packageData = do let (key, path) = case packageData of
let (key, path) = case packageData of Version path -> ("VERSION" , path)
Version path -> ("VERSION" , path) PackageKey path -> ("PACKAGE_KEY" , path)
PackageKey path -> ("PACKAGE_KEY" , path) Synopsis path -> ("SYNOPSIS" , path)
Synopsis path -> ("SYNOPSIS" , path) fullKey = replaceSeparators '_' $ path ++ "_" ++ key
fullKey = replaceSeparators '_' $ path ++ "_" ++ key pkgData = path </> "package-data.mk"
pkgData = path </> "package-data.mk" res <- askOracle $ PackageDataKey (pkgData, fullKey)
res <- askOracle $ PackageDataKey (pkgData, fullKey) return $ fromMaybe
return $ fromMaybe (error $ "No key '" ++ key ++ "' in " ++ unifyPath pkgData ++ ".") res
(error $ "No key '" ++ key ++ "' in " ++ unifyPath pkgData ++ ".")
res
instance ShowArgs MultiPackageData where pkgDataMulti :: PackageDataMulti -> Action [String]
showArgs packageData = do pkgDataMulti packageData = do
let (key, path, defaultValue) = case packageData of let (key, path, defaultValue) = case packageData of
Modules path -> ("MODULES" , path, "" ) Modules path -> ("MODULES" , path, "" )
SrcDirs path -> ("HS_SRC_DIRS" , path, ".") SrcDirs path -> ("HS_SRC_DIRS" , path, ".")
IncludeDirs path -> ("INCLUDE_DIRS" , path, ".") IncludeDirs path -> ("INCLUDE_DIRS" , path, ".")
Deps path -> ("DEPS" , path, "" ) Deps path -> ("DEPS" , path, "" )
DepKeys path -> ("DEP_KEYS" , path, "" ) DepKeys path -> ("DEP_KEYS" , path, "" )
DepNames path -> ("DEP_NAMES" , path, "" ) DepNames path -> ("DEP_NAMES" , path, "" )
CppArgs path -> ("CPP_OPTS" , path, "" ) CppArgs path -> ("CPP_OPTS" , path, "" )
HsArgs path -> ("HC_OPTS" , path, "" ) HsArgs path -> ("HC_OPTS" , path, "" )
CcArgs path -> ("CC_OPTS" , path, "" ) CcArgs path -> ("CC_OPTS" , path, "" )
CSrcs path -> ("C_SRCS" , path, "" ) CSrcs path -> ("C_SRCS" , path, "" )
DepIncludeDirs path -> ("DEP_INCLUDE_DIRS_SINGLE_QUOTED" DepIncludeDirs path -> ("DEP_INCLUDE_DIRS_SINGLE_QUOTED", path, "" )
, path, "") fullKey = replaceSeparators '_' $ path ++ "_" ++ key
fullKey = replaceSeparators '_' $ path ++ "_" ++ key pkgData = path </> "package-data.mk"
pkgData = path </> "package-data.mk" unquote = dropWhile (== '\'') . dropWhileEnd (== '\'')
unquote = dropWhile (== '\'') . dropWhileEnd (== '\'') res <- askOracle $ PackageDataKey (pkgData, fullKey)
res <- askOracle $ PackageDataKey (pkgData, fullKey) return $ map unquote $ words $ case res of
return $ map unquote $ words $ case res of Nothing -> error $ "No key '" ++ key ++ "' in "
Nothing -> error $ "No key '" ++ key ++ "' in " ++ unifyPath pkgData ++ "."
++ unifyPath pkgData ++ "." Just "" -> defaultValue
Just "" -> defaultValue Just value -> value
Just value -> value
module Oracles.Setting ( module Oracles.Setting (
Setting (..), MultiSetting (..), Setting (..), SettingMulti (..),
setting, multiSetting, setting, settingMulti,
windowsHost windowsHost
) where ) where
import Base import Stage
import Oracles.Base import Oracles.Base
import Development.Shake
-- Each Setting comes from the system.config file, e.g. 'target-os = mingw32'. -- Each Setting comes from the system.config file, e.g. 'target-os = mingw32'.
-- setting TargetOs looks up the config file and returns "mingw32". -- setting TargetOs looks up the config file and returns "mingw32".
-- --
-- MultiSetting is used for multiple string values separated by spaces, such -- SettingMulti is used for multiple string values separated by spaces, such
-- as 'src-hc-args = -H32m -O'. -- as 'src-hc-args = -H32m -O'.
-- multiSetting SrcHcArgs therefore returns a list of strings ["-H32", "-O"]. -- settingMulti SrcHcArgs therefore returns a list of strings ["-H32", "-O"].
data Setting = TargetOs data Setting = TargetOs
| TargetArch | TargetArch
| TargetPlatformFull | TargetPlatformFull
...@@ -21,7 +22,7 @@ data Setting = TargetOs ...@@ -21,7 +22,7 @@ data Setting = TargetOs
| ProjectVersion | ProjectVersion
| GhcSourcePath | GhcSourcePath
data MultiSetting = SrcHcArgs data SettingMulti = SrcHcArgs
| ConfCcArgs Stage | ConfCcArgs Stage
| ConfGccLinkerArgs Stage | ConfGccLinkerArgs Stage
| ConfLdLinkerArgs Stage | ConfLdLinkerArgs Stage
...@@ -41,8 +42,8 @@ setting s = askConfig $ case s of ...@@ -41,8 +42,8 @@ setting s = askConfig $ case s of
ProjectVersion -> "project-version" ProjectVersion -> "project-version"
GhcSourcePath -> "ghc-source-path" GhcSourcePath -> "ghc-source-path"
multiSetting :: MultiSetting -> Action [String] settingMulti :: SettingMulti -> Action [String]
multiSetting s = fmap words $ askConfig $ case s of settingMulti s = fmap words $ askConfig $ case s of
SrcHcArgs -> "src-hc-args" SrcHcArgs -> "src-hc-args"
ConfCcArgs stage -> "conf-cc-args" ++ showStage stage ConfCcArgs stage -> "conf-cc-args" ++ showStage stage
ConfCppArgs stage -> "conf-cpp-args" ++ showStage stage ConfCppArgs stage -> "conf-cpp-args" ++ showStage stage
......
...@@ -2,10 +2,11 @@ ...@@ -2,10 +2,11 @@
module Package (Package (..), library, topLevel, setCabal) where module Package (Package (..), library, topLevel, setCabal) where
import Base
import Util import Util
import Data.Function
import GHC.Generics import GHC.Generics
import Development.Shake.Classes import Development.Shake.Classes
import Development.Shake.FilePath
-- pkgPath is the path to the source code relative to the root -- pkgPath is the path to the source code relative to the root
data Package = Package data Package = Package
......
...@@ -3,13 +3,14 @@ module Rules ( ...@@ -3,13 +3,14 @@ module Rules (
module Rules.Package, module Rules.Package,
) where ) where
import Base import Stage
import Control.Monad
import Expression import Expression
import Rules.Package import Rules.Package
import Rules.Oracles import Rules.Oracles
import Settings.Packages import Settings.Packages
import Settings.TargetDirectory import Settings.TargetDirectory
import Development.Shake
import Development.Shake.FilePath
-- generateTargets needs package-data.mk files of all target packages -- generateTargets needs package-data.mk files of all target packages
-- TODO: make interpretDiff total -- TODO: make interpretDiff total
......
...@@ -2,12 +2,12 @@ module Rules.Actions ( ...@@ -2,12 +2,12 @@ module Rules.Actions (
build, buildWhen, run, verboseRun, build, buildWhen, run, verboseRun,
) where ) where
import Base
import Util import Util
import Builder import Builder
import Expression import Expression
import Settings.Args import Settings.Args
import Oracles.ArgsHash import Oracles.ArgsHash
import Development.Shake
-- Build a given target using an appropriate builder. Force a rebuilt if the -- Build a given target using an appropriate builder. Force a rebuilt if the
-- argument list has changed since the last built (that is, track changes in -- argument list has changed since the last built (that is, track changes in
......
...@@ -4,17 +4,19 @@ module Rules.Data ( ...@@ -4,17 +4,19 @@ module Rules.Data (
cabalArgs, ghcPkgArgs, buildPackageData cabalArgs, ghcPkgArgs, buildPackageData
) where ) where
import Base import Util
import Package import Package
import Builder import Builder
import Switches import Switches
import Expression import Expression
import Control.Monad.Extra
import Settings.GhcPkg import Settings.GhcPkg
import Settings.GhcCabal import Settings.GhcCabal
import Settings.TargetDirectory import Settings.TargetDirectory
import Rules.Actions import Rules.Actions
import Util import Control.Applicative
import Control.Monad.Extra
import Development.Shake
import Development.Shake.FilePath
-- Build package-data.mk by using GhcCabal to process pkgCabal file -- Build package-data.mk by using GhcCabal to process pkgCabal file
buildPackageData :: StagePackageTarget -> Rules () buildPackageData :: StagePackageTarget -> Rules ()
......
...@@ -2,9 +2,10 @@ module Rules.Oracles ( ...@@ -2,9 +2,10 @@ module Rules.Oracles (
oracleRules oracleRules
) where ) where
import Base
import Oracles import Oracles
import Oracles.ArgsHash import Oracles.ArgsHash
import Data.Monoid
import Development.Shake
oracleRules :: Rules () oracleRules :: Rules ()
oracleRules = oracleRules =
......
...@@ -2,9 +2,9 @@ module Rules.Package ( ...@@ -2,9 +2,9 @@ module Rules.Package (
buildPackage buildPackage
) where ) where
import Base
import Rules.Data import Rules.Data
import Expression import Expression
import Development.Shake