Commit 190f3fde authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Merge Base.hs and Util.hs.

parent f68d70f0
module Base ( module Base (
module Control.Applicative,
module Control.Monad.Extra,
module Data.Char,
module Data.Function,
module Data.List,
module Data.Maybe,
module Data.Monoid,
module Development.Shake, module Development.Shake,
module Development.Shake.Classes, module Development.Shake.Classes,
module Development.Shake.Config, module Development.Shake.Config,
module Development.Shake.FilePath, module Development.Shake.FilePath,
module Development.Shake.Util, module Development.Shake.Util,
shakeFilesPath, configPath, bootPackageConstraints, packageDependencies module System.Console.ANSI,
shakeFilesPath, configPath, bootPackageConstraints, packageDependencies,
replaceEq, replaceSeparators, decodeModule,
unifyPath, (-/-), chunksOfSize,
putColoured, putOracle, putBuild, putSuccess, putError,
bimap, minusOrd, intersectOrd,
removeFileIfExists
) where ) where
import Development.Shake hiding (unit) import Control.Applicative
import Control.Monad.Extra
import Data.Char
import Data.Function
import Data.List
import Data.Maybe
import Data.Monoid
import Development.Shake hiding (unit, (*>))
import Development.Shake.Classes import Development.Shake.Classes
import Development.Shake.Config import Development.Shake.Config
import Development.Shake.FilePath import Development.Shake.FilePath
import Development.Shake.Util import Development.Shake.Util
import System.Console.ANSI
import qualified System.Directory as IO
import System.IO
-- Build system files and paths
shakeFilesPath :: FilePath shakeFilesPath :: FilePath
shakeFilesPath = "_build/" shakeFilesPath = "_build/"
...@@ -24,3 +48,94 @@ bootPackageConstraints = shakeFilesPath ++ "boot-package-constraints" ...@@ -24,3 +48,94 @@ bootPackageConstraints = shakeFilesPath ++ "boot-package-constraints"
packageDependencies :: FilePath packageDependencies :: FilePath
packageDependencies = shakeFilesPath ++ "package-dependencies" packageDependencies = shakeFilesPath ++ "package-dependencies"
-- Utility functions
replaceIf :: (a -> Bool) -> a -> [a] -> [a]
replaceIf p to = map (\from -> if p from then to else from)
replaceEq :: Eq a => a -> a -> [a] -> [a]
replaceEq from = replaceIf (== from)
replaceSeparators :: Char -> String -> String
replaceSeparators = replaceIf isPathSeparator
-- Given a module name extract the directory and file names, e.g.:
-- decodeModule "Data.Functor.Identity" = ("Data/Functor/", "Identity")
decodeModule :: String -> (FilePath, String)
decodeModule = splitFileName . replaceEq '.' '/'
-- Normalise a path and convert all path separators to /, even on Windows.
unifyPath :: FilePath -> FilePath
unifyPath = toStandard . normaliseEx
-- Combine paths using </> and apply unifyPath to the result
(-/-) :: FilePath -> FilePath -> FilePath
a -/- b = unifyPath $ a </> b
infixr 6 -/-
-- (chunksOfSize size strings) splits a given list of strings into chunks not
-- exceeding the given 'size'.
chunksOfSize :: Int -> [String] -> [[String]]
chunksOfSize _ [] = []
chunksOfSize size strings = reverse chunk : chunksOfSize size rest
where
(chunk, rest) = go [] 0 strings
go res _ [] = (res, [])
go res chunkSize (s:ss) =
if newSize > size then (res, s:ss) else go (s:res) newSize ss
where
newSize = chunkSize + length s
-- A more colourful version of Shake's putNormal
putColoured :: Color -> String -> Action ()
putColoured colour msg = do
liftIO $ setSGR [SetColor Foreground Vivid colour]
putNormal msg
liftIO $ setSGR []
liftIO $ hFlush stdout
-- Make oracle output more distinguishable
putOracle :: String -> Action ()
putOracle = putColoured Blue
-- Make build output more distinguishable
putBuild :: String -> Action ()
putBuild = putColoured White
-- A more colourful version of success message
putSuccess :: String -> Action ()
putSuccess = putColoured Green
-- A more colourful version of error message
putError :: String -> Action a
putError msg = do
putColoured Red msg
error $ "GHC build system error: " ++ msg
-- Depending on Data.Bifunctor only for this function seems an overkill
bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
bimap f g (x, y) = (f x, g y)
-- Depending on Data.List.Ordered only for these two functions seems an overkill
minusOrd :: Ord a => [a] -> [a] -> [a]
minusOrd [] _ = []
minusOrd xs [] = xs
minusOrd (x:xs) (y:ys) = case compare x y of
LT -> x : minusOrd xs (y:ys)
EQ -> minusOrd xs ys
GT -> minusOrd (x:xs) ys
intersectOrd :: (a -> b -> Ordering) -> [a] -> [b] -> [a]
intersectOrd cmp = loop
where
loop [] _ = []
loop _ [] = []
loop (x:xs) (y:ys) = case cmp x y of
LT -> loop xs (y:ys)
EQ -> x : loop xs ys
GT -> loop (x:xs) ys
-- Convenient helper function for removing a file that doesn't necessarily exist
removeFileIfExists :: FilePath -> Action ()
removeFileIfExists f = liftIO . whenM (IO.doesFileExist f) $ IO.removeFile f
...@@ -2,7 +2,6 @@ ...@@ -2,7 +2,6 @@
module Builder (Builder (..), builderPath, specified, needBuilder) where module Builder (Builder (..), builderPath, specified, needBuilder) where
import Base import Base
import Util
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Oracles import Oracles
import Stage import Stage
......
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
module Expression ( module Expression (
module Base,
module Control.Monad.Reader, module Control.Monad.Reader,
module Builder, module Builder,
module Package, module Package,
module Stage, module Stage,
module Util,
module Way, module Way,
Expr, DiffExpr, fromDiffExpr, Expr, DiffExpr, fromDiffExpr,
Predicate, (?), (??), notP, applyPredicate, Predicate, (?), (??), notP, applyPredicate,
...@@ -22,7 +22,6 @@ import Control.Monad.Reader ...@@ -22,7 +22,6 @@ import Control.Monad.Reader
import Package import Package
import Stage import Stage
import Target (Target (..), PartialTarget (..), fromPartial) import Target (Target (..), PartialTarget (..), fromPartial)
import Util
import Way import Way
-- 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
......
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Oracles.ArgsHash ( module Oracles.ArgsHash (
checkArgsHash, argsHashOracle checkArgsHash, argsHashOracle
) where ) where
import Base
import Target import Target
import Expression import Expression
import Settings import Settings
......
...@@ -2,7 +2,6 @@ ...@@ -2,7 +2,6 @@
module Oracles.Config (askConfig, askConfigWithDefault, configOracle) where module Oracles.Config (askConfig, askConfigWithDefault, configOracle) where
import Base import Base
import Util
import qualified Data.HashMap.Strict as Map import qualified Data.HashMap.Strict as Map
newtype ConfigKey = ConfigKey String newtype ConfigKey = ConfigKey String
......
...@@ -5,7 +5,6 @@ module Oracles.Config.Flag ( ...@@ -5,7 +5,6 @@ module Oracles.Config.Flag (
) where ) where
import Base import Base
import Util
import Oracles.Config import Oracles.Config
import Oracles.Config.Setting import Oracles.Config.Setting
......
...@@ -6,7 +6,6 @@ module Oracles.Dependencies ( ...@@ -6,7 +6,6 @@ module Oracles.Dependencies (
) where ) where
import Base import Base
import Util
import qualified Data.HashMap.Strict as Map import qualified Data.HashMap.Strict as Map
newtype DependenciesKey = DependenciesKey (FilePath, FilePath) newtype DependenciesKey = DependenciesKey (FilePath, FilePath)
......
...@@ -6,7 +6,6 @@ module Oracles.PackageData ( ...@@ -6,7 +6,6 @@ module Oracles.PackageData (
) where ) where
import Base import Base
import Util
import qualified Data.HashMap.Strict as Map import qualified Data.HashMap.Strict as Map
-- For each (PackageData path) the file 'path/package-data.mk' contains -- For each (PackageData path) the file 'path/package-data.mk' contains
......
...@@ -6,7 +6,6 @@ module Oracles.PackageDeps ( ...@@ -6,7 +6,6 @@ module Oracles.PackageDeps (
) where ) where
import Base import Base
import Util
import Package import Package
import qualified Data.HashMap.Strict as Map import qualified Data.HashMap.Strict as Map
......
...@@ -5,7 +5,6 @@ module Oracles.WindowsRoot ( ...@@ -5,7 +5,6 @@ module Oracles.WindowsRoot (
) where ) where
import Base import Base
import Util
newtype WindowsRoot = WindowsRoot () newtype WindowsRoot = WindowsRoot ()
deriving (Show, Typeable, Eq, Hashable, Binary, NFData) deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
......
...@@ -6,7 +6,6 @@ module Package ( ...@@ -6,7 +6,6 @@ module Package (
import Base import Base
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Util
-- It is helpful to distinguish package names from strings. -- It is helpful to distinguish package names from strings.
type PackageName = String type PackageName = String
......
...@@ -4,7 +4,6 @@ module Predicates ( ...@@ -4,7 +4,6 @@ module Predicates (
registerPackage, splitObjects registerPackage, splitObjects
) where ) where
import Base
import Expression import Expression
import GHC import GHC
import Oracles import Oracles
......
module Rules (generateTargets, packageRules) where module Rules (generateTargets, packageRules) where
import Base
import Expression import Expression
import Oracles.PackageData import Oracles.PackageData
import Rules.Package import Rules.Package
import Rules.Resources import Rules.Resources
import Settings.Packages import Settings
import Settings.User
import Settings.Util
import Settings.Ways
import Target (PartialTarget (..)) import Target (PartialTarget (..))
-- generateTargets needs top-level build targets -- generateTargets needs top-level build targets
......
module Rules.Actions (build, buildWithResources) where module Rules.Actions (build, buildWithResources) where
import Base
import Util
import Target hiding (builder) import Target hiding (builder)
import qualified Target import qualified Target
import Builder import Builder
...@@ -10,7 +8,6 @@ import Oracles ...@@ -10,7 +8,6 @@ import Oracles
import Oracles.ArgsHash import Oracles.ArgsHash
import Settings import Settings
import Settings.Args import Settings.Args
import Settings.Builders.Ar
-- Build a given target using an appropriate builder and acquiring necessary -- Build a given target using an appropriate builder and acquiring necessary
-- resources. Force a rebuilt if the argument list has changed since the last -- resources. Force a rebuilt if the argument list has changed since the last
......
module Rules.Cabal (cabalRules) where module Rules.Cabal (cabalRules) where
import Base
import Stage import Stage
import Package hiding (library) import Package hiding (library)
import Expression import Expression
......
...@@ -2,7 +2,6 @@ module Rules.Compile (compilePackage) where ...@@ -2,7 +2,6 @@ module Rules.Compile (compilePackage) where
import Way import Way
import Base import Base
import Util
import Builder import Builder
import Target (PartialTarget (..), fullTarget, fullTargetWithWay) import Target (PartialTarget (..), fullTarget, fullTargetWithWay)
import Oracles.Dependencies import Oracles.Dependencies
......
module Rules.Config (configRules) where module Rules.Config (configRules) where
import Base import Base
import Util
-- We add the following line to 'configure.ac' in order to produce configuration -- We add the following line to 'configure.ac' in order to produce configuration
-- file "system.config" from "system.config.in" by running 'configure' script. -- file "system.config" from "system.config.in" by running 'configure' script.
......
module Rules.Data (buildPackageData) where module Rules.Data (buildPackageData) where
import Base
import Util
import Target (PartialTarget (..), fullTarget) import Target (PartialTarget (..), fullTarget)
import Package import Package
import Builder import Builder
......
module Rules.Dependencies (buildPackageDependencies) where module Rules.Dependencies (buildPackageDependencies) where
import Base
import Util
import Builder import Builder
import Package import Package
import Expression import Expression
......
module Rules.Documentation (buildPackageDocumentation) where module Rules.Documentation (buildPackageDocumentation) where
import Way import Way
import Base
import Stage import Stage
import Builder import Builder
import Package import Package
......
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