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

Merge Base.hs and Util.hs.

parent f68d70f0
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.Classes,
module Development.Shake.Config,
module Development.Shake.FilePath,
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
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.Config
import Development.Shake.FilePath
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 = "_build/"
......@@ -24,3 +48,94 @@ bootPackageConstraints = shakeFilesPath ++ "boot-package-constraints"
packageDependencies :: FilePath
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 @@
module Builder (Builder (..), builderPath, specified, needBuilder) where
import Base
import Util
import GHC.Generics (Generic)
import Oracles
import Stage
......
{-# LANGUAGE FlexibleInstances #-}
module Expression (
module Base,
module Control.Monad.Reader,
module Builder,
module Package,
module Stage,
module Util,
module Way,
Expr, DiffExpr, fromDiffExpr,
Predicate, (?), (??), notP, applyPredicate,
......@@ -22,7 +22,6 @@ import Control.Monad.Reader
import Package
import Stage
import Target (Target (..), PartialTarget (..), fromPartial)
import Util
import Way
-- Expr a is a computation that produces a value of type Action a and can read
......
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Oracles.ArgsHash (
checkArgsHash, argsHashOracle
) where
import Base
import Target
import Expression
import Settings
......
......@@ -2,7 +2,6 @@
module Oracles.Config (askConfig, askConfigWithDefault, configOracle) where
import Base
import Util
import qualified Data.HashMap.Strict as Map
newtype ConfigKey = ConfigKey String
......
......@@ -5,7 +5,6 @@ module Oracles.Config.Flag (
) where
import Base
import Util
import Oracles.Config
import Oracles.Config.Setting
......
......@@ -6,7 +6,6 @@ module Oracles.Dependencies (
) where
import Base
import Util
import qualified Data.HashMap.Strict as Map
newtype DependenciesKey = DependenciesKey (FilePath, FilePath)
......
......@@ -6,7 +6,6 @@ module Oracles.PackageData (
) where
import Base
import Util
import qualified Data.HashMap.Strict as Map
-- For each (PackageData path) the file 'path/package-data.mk' contains
......
......@@ -6,7 +6,6 @@ module Oracles.PackageDeps (
) where
import Base
import Util
import Package
import qualified Data.HashMap.Strict as Map
......
......@@ -5,7 +5,6 @@ module Oracles.WindowsRoot (
) where
import Base
import Util
newtype WindowsRoot = WindowsRoot ()
deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
......
......@@ -6,7 +6,6 @@ module Package (
import Base
import GHC.Generics (Generic)
import Util
-- It is helpful to distinguish package names from strings.
type PackageName = String
......
......@@ -4,7 +4,6 @@ module Predicates (
registerPackage, splitObjects
) where
import Base
import Expression
import GHC
import Oracles
......
module Rules (generateTargets, packageRules) where
import Base
import Expression
import Oracles.PackageData
import Rules.Package
import Rules.Resources
import Settings.Packages
import Settings.User
import Settings.Util
import Settings.Ways
import Settings
import Target (PartialTarget (..))
-- generateTargets needs top-level build targets
......
module Rules.Actions (build, buildWithResources) where
import Base
import Util
import Target hiding (builder)
import qualified Target
import Builder
......@@ -10,7 +8,6 @@ import Oracles
import Oracles.ArgsHash
import Settings
import Settings.Args
import Settings.Builders.Ar
-- Build a given target using an appropriate builder and acquiring necessary
-- resources. Force a rebuilt if the argument list has changed since the last
......
module Rules.Cabal (cabalRules) where
import Base
import Stage
import Package hiding (library)
import Expression
......
......@@ -2,7 +2,6 @@ module Rules.Compile (compilePackage) where
import Way
import Base
import Util
import Builder
import Target (PartialTarget (..), fullTarget, fullTargetWithWay)
import Oracles.Dependencies
......
module Rules.Config (configRules) where
import Base
import Util
-- We add the following line to 'configure.ac' in order to produce configuration
-- file "system.config" from "system.config.in" by running 'configure' script.
......
module Rules.Data (buildPackageData) where
import Base
import Util
import Target (PartialTarget (..), fullTarget)
import Package
import Builder
......
module Rules.Dependencies (buildPackageDependencies) where
import Base
import Util
import Builder
import Package
import Expression
......
module Rules.Documentation (buildPackageDocumentation) where
import Way
import Base
import Stage
import Builder
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