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

Merge Base.hs and Util.hs.

parent f68d70f0
module Rules.Library (buildPackageLibrary) where
import Base hiding (splitPath, getDirectoryContents)
import Expression
import Expression hiding (splitPath)
import Oracles.PackageData
import Predicates (splitObjects)
import Rules.Actions
import Rules.Resources
import Settings
import System.Directory (getDirectoryContents)
import qualified System.Directory as IO
import Target (PartialTarget (..), fullTarget)
buildPackageLibrary :: Resources -> PartialTarget -> Rules ()
......@@ -33,7 +32,7 @@ buildPackageLibrary _ target @ (PartialTarget stage pkg) = do
splitObjs <- if not split then return [] else
fmap concat $ forM hSrcs $ \src -> do
let splitPath = buildPath -/- src ++ "_" ++ osuf way ++ "_split"
contents <- liftIO $ getDirectoryContents splitPath
contents <- liftIO $ IO.getDirectoryContents splitPath
return . map (splitPath -/-)
. filter (not . all (== '.')) $ contents
......
module Rules.Package (buildPackage) where
import Base
import Expression
import Rules.Compile
import Rules.Data
import Rules.Dependencies
......
module Rules.Resources (resourceRules, Resources (..)) where
import Base
import Util
data Resources = Resources
{
......
module Settings.Args (args, getArgs) where
module Settings.Args (args, getArgs, arPersistentArgsCount) where
import Expression
import Settings
......
module Settings.Builders.Gcc (gccArgs, gccMArgs) where
import Base
import Util
import Expression
import Predicates (stagedBuilder)
import Oracles.PackageData
......
module Settings.Builders.Ghc (ghcArgs, ghcMArgs, commonGhcArgs) where
import Util
import Expression
import Predicates (stagedBuilder, splitObjects, stage0)
import Oracles
......
......@@ -4,8 +4,6 @@ module Settings.Builders.GhcCabal (
) where
import Way
import Base
import Util
import Stage
import Builder
import Package
......
module Settings.Builders.GhcPkg (ghcPkgArgs) where
import Util
import Builder
import Expression
import Predicates
......
module Settings.Builders.Haddock (haddockArgs) where
import Base
import Util
import Builder
import Package
import Expression
......
......@@ -3,7 +3,6 @@ module Settings.TargetDirectory (
) where
import Base
import Util
import Stage
import Package
import Settings.User
......
......@@ -9,7 +9,6 @@ module Settings.Util (
appendCcArgs
) where
import Base
import Stage
import Builder
import Package
......
module Settings.Ways (getWays, getRtsWays) where
import Way
import Stage
import Expression
import Predicates
......
......@@ -11,7 +11,6 @@ import GHC.Generics (Generic)
import Package
import Stage
import Way
import Util
-- Target captures all parameters relevant to the current build target:
-- * Stage and Package being built,
......
module Util (
module Control.Applicative,
module Control.Monad.Extra,
module Data.Char,
module Data.Function,
module Data.List,
module Data.Maybe,
module Data.Monoid,
module System.Console.ANSI,
replaceEq, replaceSeparators, decodeModule,
unifyPath, (-/-), chunksOfSize,
putColoured, putOracle, putBuild, putSuccess, putError,
bimap, minusOrd, intersectOrd,
removeFileIfExists
) where
import Base hiding (doesFileExist)
import Control.Applicative
import Control.Monad.Extra
import Data.Char
import Data.Function
import Data.List
import Data.Maybe
import Data.Monoid
import System.Console.ANSI
import System.Directory (doesFileExist, removeFile)
import System.IO
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 file = liftIO . whenM (doesFileExist file) $ removeFile file
......@@ -12,11 +12,10 @@ module Way (
safeDetectWay, detectWay, matchBuildResult
) where
import Base
import Base hiding (unit)
import Data.IntSet (IntSet)
import qualified Data.IntSet as Set
import Oracles
import Util hiding (unit)
data WayUnit = Threaded
| Debug
......
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