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 (
Builder (..), builderKey, builderPath, needBuilder
) where
import Base
import Util
import Stage
import Data.List
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
--
......
......@@ -2,8 +2,9 @@ module Config (
autoconfRules, configureRules, cfgPath
) where
import Base
import Util
import Development.Shake
import Development.Shake.FilePath
cfgPath :: FilePath
cfgPath = "shake" </> "cfg"
......
......@@ -12,14 +12,15 @@ module Expression (
) where
import Way
import Base
import Stage
import Builder
import Package
import Target
import Data.List
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 Base
import Rules
import Config
import Development.Shake
main = shakeArgs shakeOptions{shakeFiles="_build/"} $ do
oracleRules -- see module Rules.Oracles
......
......@@ -3,17 +3,20 @@ module Oracles (
configOracle, packageDataOracle, dependencyOracle
) where
import Development.Shake.Config
import Development.Shake.Util
import qualified Data.HashMap.Strict as M
import Base
import Util
import Config
import Control.Monad.Extra
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 ()
......
......@@ -4,9 +4,10 @@ module Oracles.ArgsHash (
ArgsHashKey (..), askArgsHash, argsHashOracle
) where
import Base
import Expression
import Settings.Args
import Control.Applicative
import Development.Shake
import Development.Shake.Classes
newtype ArgsHashKey = ArgsHashKey FullTarget
......
......@@ -5,8 +5,8 @@ module Oracles.Base (
askConfigWithDefault, askConfig
) where
import Base
import Util
import Development.Shake
import Development.Shake.Classes
newtype ConfigKey = ConfigKey String
......
......@@ -2,19 +2,20 @@
module Oracles.DependencyList (
DependencyList (..),
DependencyListKey (..)
DependencyListKey (..),
dependencyList
) where
import Development.Shake.Classes
import Base
import Data.Maybe
import Development.Shake
import Development.Shake.Classes
data DependencyList = DependencyList FilePath FilePath
newtype DependencyListKey = DependencyListKey (FilePath, FilePath)
deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
instance ShowArgs DependencyList where
showArgs (DependencyList file obj) = do
dependencyList :: DependencyList -> Action [FilePath]
dependencyList (DependencyList file obj) = do
res <- askOracle $ DependencyListKey (file, obj)
return $ fromMaybe [] res
......@@ -3,9 +3,9 @@ module Oracles.Flag (
test
) where
import Base
import Util
import Oracles.Base
import Development.Shake
data Flag = LaxDeps
| DynamicGhcPrograms
......
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Oracles.PackageData (
PackageData (..), MultiPackageData (..),
PackageDataKey (..), askPackageData
PackageData (..), PackageDataMulti (..),
PackageDataKey (..),
pkgData, pkgDataMulti
) where
import Development.Shake.Classes
import Base
import Util
import Data.List
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
-- 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".
--
-- 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 ...'.
-- (showArgs Modules) therefore returns ["Data.Array", "Data.Array.Base", ...].
-- pkgMultiData Modules therefore returns ["Data.Array", "Data.Array.Base", ...]
data PackageData = Version FilePath
| PackageKey FilePath
| Synopsis FilePath
data MultiPackageData = Modules FilePath
data PackageDataMulti = Modules FilePath
| SrcDirs FilePath
| IncludeDirs FilePath
| Deps FilePath
......@@ -47,41 +49,38 @@ askPackageData path key = do
return $ fromMaybe
(error $ "No key '" ++ key ++ "' in " ++ pkgData ++ ".") value
-- TODO: remove
instance ShowArg PackageData where
showArg packageData = do
let (key, path) = case packageData of
Version path -> ("VERSION" , path)
PackageKey path -> ("PACKAGE_KEY" , path)
Synopsis path -> ("SYNOPSIS" , path)
fullKey = replaceSeparators '_' $ path ++ "_" ++ key
pkgData = path </> "package-data.mk"
res <- askOracle $ PackageDataKey (pkgData, fullKey)
return $ fromMaybe
(error $ "No key '" ++ key ++ "' in " ++ unifyPath pkgData ++ ".")
res
pkgData :: PackageData -> Action String
pkgData packageData = do
let (key, path) = case packageData of
Version path -> ("VERSION" , path)
PackageKey path -> ("PACKAGE_KEY" , path)
Synopsis path -> ("SYNOPSIS" , path)
fullKey = replaceSeparators '_' $ path ++ "_" ++ key
pkgData = path </> "package-data.mk"
res <- askOracle $ PackageDataKey (pkgData, fullKey)
return $ fromMaybe
(error $ "No key '" ++ key ++ "' in " ++ unifyPath pkgData ++ ".") res
instance ShowArgs MultiPackageData where
showArgs packageData = do
let (key, path, defaultValue) = case packageData of
Modules path -> ("MODULES" , path, "" )
SrcDirs path -> ("HS_SRC_DIRS" , path, ".")
IncludeDirs path -> ("INCLUDE_DIRS" , path, ".")
Deps path -> ("DEPS" , path, "" )
DepKeys path -> ("DEP_KEYS" , path, "" )
DepNames path -> ("DEP_NAMES" , path, "" )
CppArgs path -> ("CPP_OPTS" , path, "" )
HsArgs path -> ("HC_OPTS" , path, "" )
CcArgs path -> ("CC_OPTS" , path, "" )
CSrcs path -> ("C_SRCS" , path, "" )
DepIncludeDirs path -> ("DEP_INCLUDE_DIRS_SINGLE_QUOTED"
, path, "")
fullKey = replaceSeparators '_' $ path ++ "_" ++ key
pkgData = path </> "package-data.mk"
unquote = dropWhile (== '\'') . dropWhileEnd (== '\'')
res <- askOracle $ PackageDataKey (pkgData, fullKey)
return $ map unquote $ words $ case res of
Nothing -> error $ "No key '" ++ key ++ "' in "
++ unifyPath pkgData ++ "."
Just "" -> defaultValue
Just value -> value
pkgDataMulti :: PackageDataMulti -> Action [String]
pkgDataMulti packageData = do
let (key, path, defaultValue) = case packageData of
Modules path -> ("MODULES" , path, "" )
SrcDirs path -> ("HS_SRC_DIRS" , path, ".")
IncludeDirs path -> ("INCLUDE_DIRS" , path, ".")
Deps path -> ("DEPS" , path, "" )
DepKeys path -> ("DEP_KEYS" , path, "" )
DepNames path -> ("DEP_NAMES" , path, "" )
CppArgs path -> ("CPP_OPTS" , path, "" )
HsArgs path -> ("HC_OPTS" , path, "" )
CcArgs path -> ("CC_OPTS" , path, "" )
CSrcs path -> ("C_SRCS" , path, "" )
DepIncludeDirs path -> ("DEP_INCLUDE_DIRS_SINGLE_QUOTED", path, "" )
fullKey = replaceSeparators '_' $ path ++ "_" ++ key
pkgData = path </> "package-data.mk"
unquote = dropWhile (== '\'') . dropWhileEnd (== '\'')
res <- askOracle $ PackageDataKey (pkgData, fullKey)
return $ map unquote $ words $ case res of
Nothing -> error $ "No key '" ++ key ++ "' in "
++ unifyPath pkgData ++ "."
Just "" -> defaultValue
Just value -> value
module Oracles.Setting (
Setting (..), MultiSetting (..),
setting, multiSetting,
Setting (..), SettingMulti (..),
setting, settingMulti,
windowsHost
) where
import Base
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".
--
-- 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'.
-- multiSetting SrcHcArgs therefore returns a list of strings ["-H32", "-O"].
-- settingMulti SrcHcArgs therefore returns a list of strings ["-H32", "-O"].
data Setting = TargetOs
| TargetArch
| TargetPlatformFull
......@@ -21,7 +22,7 @@ data Setting = TargetOs
| ProjectVersion
| GhcSourcePath
data MultiSetting = SrcHcArgs
data SettingMulti = SrcHcArgs
| ConfCcArgs Stage
| ConfGccLinkerArgs Stage
| ConfLdLinkerArgs Stage
......@@ -41,8 +42,8 @@ setting s = askConfig $ case s of
ProjectVersion -> "project-version"
GhcSourcePath -> "ghc-source-path"
multiSetting :: MultiSetting -> Action [String]
multiSetting s = fmap words $ askConfig $ case s of
settingMulti :: SettingMulti -> Action [String]
settingMulti s = fmap words $ askConfig $ case s of
SrcHcArgs -> "src-hc-args"
ConfCcArgs stage -> "conf-cc-args" ++ showStage stage
ConfCppArgs stage -> "conf-cpp-args" ++ showStage stage
......
......@@ -2,10 +2,11 @@
module Package (Package (..), library, topLevel, setCabal) where
import Base
import Util
import Data.Function
import GHC.Generics
import Development.Shake.Classes
import Development.Shake.FilePath
-- pkgPath is the path to the source code relative to the root
data Package = Package
......
......@@ -3,13 +3,14 @@ module Rules (
module Rules.Package,
) where
import Base
import Control.Monad
import Stage
import Expression
import Rules.Package
import Rules.Oracles
import Settings.Packages
import Settings.TargetDirectory
import Development.Shake
import Development.Shake.FilePath
-- generateTargets needs package-data.mk files of all target packages
-- TODO: make interpretDiff total
......
......@@ -2,12 +2,12 @@ module Rules.Actions (
build, buildWhen, run, verboseRun,
) where
import Base
import Util
import Builder
import Expression
import Settings.Args
import Oracles.ArgsHash
import Development.Shake
-- 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
......
......@@ -4,17 +4,19 @@ module Rules.Data (
cabalArgs, ghcPkgArgs, buildPackageData
) where
import Base
import Util
import Package
import Builder
import Switches
import Expression
import Control.Monad.Extra
import Settings.GhcPkg
import Settings.GhcCabal
import Settings.TargetDirectory
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
buildPackageData :: StagePackageTarget -> Rules ()
......
......@@ -2,9 +2,10 @@ module Rules.Oracles (
oracleRules
) where
import Base
import Oracles
import Oracles.ArgsHash
import Data.Monoid
import Development.Shake
oracleRules :: Rules ()
oracleRules =
......
......@@ -2,9 +2,9 @@ module Rules.Package (
buildPackage
) where
import Base
import Rules.Data
import Expression
import Development.Shake
buildPackage :: StagePackageTarget -> Rules ()
buildPackage = buildPackageData
......@@ -2,10 +2,9 @@ module Settings.Args (
args
) where
import Base
import Settings.User
import Settings.GhcPkg
import Settings.GhcCabal
import Settings.User
import Expression
args :: Args
......
......@@ -7,7 +7,7 @@ module Settings.Default (
templateHaskell, terminfo, time, transformers, unix, win32, xhtml
) where
import Base
import Stage
import Package
-- Build results will be placed into a target directory with the following
......
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