Commit 9737176b authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Remove unused code from Base and Oracles.

parent da64dcaf
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveGeneric, FlexibleInstances #-}
module Base (
module Development.Shake,
......@@ -11,12 +10,11 @@ module Base (
Stage (..),
Arg, ArgList,
ShowArg (..), ShowArgs (..),
Condition (..),
filterOut,
productArgs, concatArgs
) where
import Development.Shake hiding ((*>), alternatives)
import Development.Shake hiding ((*>))
import Development.Shake.FilePath
import Control.Applicative
import Data.Function
......@@ -39,8 +37,6 @@ instance Hashable Stage
type Arg = Action String
type ArgList = Action [String]
type Condition = Action Bool
instance Monoid a => Monoid (Action a) where
mempty = return mempty
mappend p q = mappend <$> p <*> q
......
{-# LANGUAGE NoImplicitPrelude, FlexibleInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module Expression (
module Target,
module Data.Monoid,
......@@ -11,13 +11,14 @@ module Expression (
configKeyValue, configKeyValues
) where
import Base hiding (Args)
import Base
import Ways
import Target
import Oracles
import Oracles.Base
import Oracles.Builder
import Package
import Data.Monoid
import Control.Monad.Reader
import Control.Monad.Reader hiding (liftIO)
-- Expr a is a computation that produces a value of type Action a and can read
-- parameters of the current build Target.
......
module Oracles (
module Oracles.Base,
module Oracles.Flag,
module Oracles.Option,
module Oracles.Builder,
module Oracles.PackageData,
module Oracles.DependencyList,
configOracle, packageDataOracle, dependencyOracle
) where
......@@ -17,10 +12,8 @@ import Base
import Util
import Config
import Oracles.Base
import Oracles.Flag
import Oracles.Option
import Oracles.Builder
import Oracles.PackageData
import Control.Monad.Extra
import Oracles.DependencyList
defaultConfig, userConfig :: FilePath
......@@ -31,7 +24,7 @@ userConfig = cfgPath </> "user.config"
configOracle :: Rules ()
configOracle = do
cfg <- newCache $ \() -> do
unless (doesFileExist $ defaultConfig <.> "in") $
unlessM (doesFileExist $ defaultConfig <.> "in") $
redError_ $ "\nDefault configuration file '"
++ (defaultConfig <.> "in")
++ "' is missing; unwilling to proceed."
......
......@@ -5,7 +5,7 @@ module Oracles.ArgsHash (
) where
import Development.Shake.Classes
import Base hiding (args)
import Base
import Settings
import Expression
......
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Oracles.Builder (
Builder (..), builderKey, withBuilderKey,
......@@ -9,8 +8,8 @@ module Oracles.Builder (
import Data.Char
import Base
import Util
import Oracles.Base
import Oracles.Flag
import Oracles.Base
import Oracles.Option
import GHC.Generics
import Development.Shake.Classes
......@@ -34,6 +33,7 @@ data Builder = Ar
| GhcPkg Stage
deriving (Show, Eq, Generic)
-- Instances for storing Target in the Shake database
instance Binary Builder
instance Hashable Builder
......@@ -148,6 +148,7 @@ interestingInfo builder ss = case builder of
++ " arguments ..."]
++ drop (length ss - m) ss
-- TODO: remove?
-- Check if the builder is specified in config files
specified :: Builder -> Condition
specified :: Builder -> Action Bool
specified = fmap (not . null) . showArg
{-# LANGUAGE TypeFamilies, FlexibleInstances, MultiParamTypeClasses #-}
module Oracles.Flag (
module Control.Monad,
module Prelude,
Flag (..),
test, when, unless, not, (&&), (||)
test
) where
import qualified Prelude
import Prelude hiding (not, (&&), (||))
import Control.Monad hiding (when, unless)
import Base
import Util
import Oracles.Base
......@@ -49,66 +42,3 @@ test flag = do
++ "'.\n"
return defaultString
return $ value == "YES"
class ToCondition a where
toCondition :: a -> Condition
instance ToCondition Condition where
toCondition = id
instance ToCondition Bool where
toCondition = return
instance ToCondition Flag where
toCondition = test
when :: (ToCondition a, Monoid m) => a -> Action m -> Action m
when x act = do
bool <- toCondition x
if bool then act else mempty
unless :: (ToCondition a, Monoid m) => a -> Action m -> Action m
unless x act = do
bool <- toCondition x
if bool then mempty else act
class Not a where
type NotResult a
not :: a -> NotResult a
instance Not Bool where
type NotResult Bool = Bool
not = Prelude.not
instance Not Condition where
type NotResult Condition = Condition
not = fmap not
instance Not Flag where
type NotResult Flag = Condition
not = not . toCondition
class AndOr a b where
type AndOrResult a b
(&&) :: a -> b -> AndOrResult a b
(||) :: a -> b -> AndOrResult a b
infixr 3 &&
infixr 2 ||
instance AndOr Bool Bool where
type AndOrResult Bool Bool = Bool
(&&) = (Prelude.&&)
(||) = (Prelude.||)
instance ToCondition a => AndOr Condition a where
type AndOrResult Condition a = Condition
x && y = (&&) <$> x <*> toCondition y
x || y = (||) <$> x <*> toCondition y
instance ToCondition a => AndOr Flag a where
type AndOrResult Flag a = Condition
x && y = toCondition x && y
x || y = toCondition x || y
-- TODO: need more instances to handle Bool as first argument of (&&), (||)
{-# LANGUAGE NoImplicitPrelude #-}
module Oracles.Option (
Option (..), MultiOption (..),
ghcWithInterpreter, platformSupportsSharedLibs, windowsHost, splitObjects
Option (..), MultiOption (..), windowsHost
) where
import Base
import Oracles.Flag
import Oracles.Base
-- For each Option the files {default.config, user.config} contain
......@@ -58,40 +55,7 @@ instance ShowArgs MultiOption where
where
showStage = ("-stage" ++) . show
ghcWithInterpreter :: Condition
ghcWithInterpreter = do
os <- showArg TargetOs
arch <- showArg TargetArch
return $
os `elem` ["mingw32", "cygwin32", "linux", "solaris2",
"freebsd", "dragonfly", "netbsd", "openbsd",
"darwin", "kfreebsdgnu"]
&&
arch `elem` ["i386", "x86_64", "powerpc", "sparc", "sparc64", "arm"]
platformSupportsSharedLibs :: Condition
platformSupportsSharedLibs = do
platform <- showArg TargetPlatformFull
solarisBrokenShld <- test SolarisBrokenShld
return $ notElem platform $
["powerpc-unknown-linux",
"x86_64-unknown-mingw32",
"i386-unknown-mingw32"] ++
["i386-unknown-solaris2" | solarisBrokenShld]
windowsHost :: Condition
windowsHost :: Action Bool
windowsHost = do
hostOsCpp <- showArg HostOsCpp
return $ hostOsCpp `elem` ["mingw32", "cygwin32"]
-- TODO: refactor helper Condition functions into a separate file
splitObjects :: Stage -> Condition
splitObjects stage = do
arch <- showArg TargetArch
os <- showArg TargetOs
not SplitObjectsBroken && not GhcUnregisterised
&& stage == Stage1
&& arch `elem` ["i386", "x86_64", "powerpc", "sparc"]
&& os `elem` ["mingw32", "cygwin32", "linux", "darwin",
"solaris2", "freebsd", "dragonfly", "netbsd",
"openbsd"]
{-# LANGUAGE NoImplicitPrelude #-}
module Rules (
generateTargets, packageRules, oracleRules,
module Rules.Package,
......
......@@ -6,8 +6,8 @@ module Rules.Data (
import Base
import Package
import Expression hiding (when, liftIO)
import Oracles.Flag (when)
import Expression
import Control.Monad.Extra
import Oracles.Builder
import Settings.GhcPkg
import Settings.GhcCabal
......@@ -39,7 +39,7 @@ buildPackageData target =
-- GhcCabal will run the configure script, so we depend on it
need [pkgPath pkg </> pkgCabal pkg]
-- We still don't know who built the configure script from configure.ac
when (doesFileExist $ configure <.> "ac") $ need [configure]
whenM (doesFileExist $ configure <.> "ac") $ need [configure]
build $ newTarget { getBuilder = GhcCabal }
-- TODO: when (registerPackage settings) $
build $ newTarget { getBuilder = GhcPkg stage }
......
......@@ -2,7 +2,7 @@ module Rules.Oracles (
oracleRules
) where
import Base hiding (arg, args, Args)
import Base
import Oracles
import Oracles.ArgsHash
......
......@@ -2,11 +2,11 @@ module Settings (
args
) where
import Base hiding (arg, args, Args)
import Base
import Settings.GhcPkg
import Settings.GhcCabal
import Settings.User
import Expression hiding (when, liftIO)
import Expression
args :: Args
args = defaultArgs <> userArgs
......
......@@ -9,7 +9,7 @@ import Ways
import Util
import Package
import Switches
import Expression hiding (liftIO)
import Expression
import Settings.User
import Settings.Ways
import Settings.Util
......
......@@ -4,7 +4,7 @@ module Settings.GhcPkg (
import Base
import Switches
import Expression hiding (when, liftIO)
import Expression
import Settings.Util
import Oracles.Builder
import Settings.GhcCabal
......
{-# LANGUAGE NoImplicitPrelude #-}
module Settings.Util (
-- Primitive settings elements
arg, argM, argWith,
......@@ -13,8 +11,9 @@ module Settings.Util (
-- argPackageConstraints,
) where
import Base hiding (Args, arg, args)
import Oracles hiding (not)
import Base
import Oracles.Base
import Oracles.Builder
import Expression
-- A single argument
......
......@@ -3,7 +3,7 @@ module Settings.Ways (
) where
import Base
import Ways hiding (defaultWays)
import Ways
import Switches
import Expression
import Settings.User
......
......@@ -90,3 +90,14 @@ windowsHost = configKeyValues "host-os-cpp" ["mingw32", "cygwin32"]
notWindowsHost :: Predicate
notWindowsHost = liftM not windowsHost
-- splitObjects :: Stage -> Condition
-- splitObjects stage = do
-- arch <- showArg TargetArch
-- os <- showArg TargetOs
-- not SplitObjectsBroken && not GhcUnregisterised
-- && stage == Stage1
-- && arch `elem` ["i386", "x86_64", "powerpc", "sparc"]
-- && os `elem` ["mingw32", "cygwin32", "linux", "darwin",
-- "solaris2", "freebsd", "dragonfly", "netbsd",
-- "openbsd"]
......@@ -5,8 +5,8 @@ module Target (
import Base
import Ways
import Oracles
import Package
import Oracles.Builder
import GHC.Generics
import Development.Shake.Classes
......
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Ways ( -- TODO: rename to "Way"?
WayUnit (..),
Way, tag,
......@@ -19,7 +18,7 @@ module Ways ( -- TODO: rename to "Way"?
) where
import Base
import Oracles
import Oracles.Option
import GHC.Generics
import Development.Shake.Classes
......
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