Commit c81dc684 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Add quote function

parent d6a0d7af
......@@ -19,7 +19,7 @@ module Base (
-- * Miscellaneous utilities
minusOrd, intersectOrd, lookupAll, replaceEq, replaceSeparators, unifyPath,
(-/-), matchVersionedFilePath, putColoured
quote, (-/-), matchVersionedFilePath, putColoured
) where
import Control.Applicative
......@@ -71,6 +71,10 @@ replaceSeparators = replaceWhen isPathSeparator
replaceWhen :: (a -> Bool) -> a -> [a] -> [a]
replaceWhen p to = map (\from -> if p from then to else from)
-- | Add single quotes around a String.
quote :: String -> String
quote s = "'" ++ s ++ "'"
-- | Normalise a path and convert all path separators to @/@, even on Windows.
unifyPath :: FilePath -> FilePath
unifyPath = toStandard . normaliseEx
......
......@@ -121,13 +121,13 @@ builderPath builder = case builderProvenance builder of
_ -> error $ "Cannot determine builderPath for " ++ show builder
where
fromKey key = do
path <- askConfigWithDefault key . error $ "\nCannot find path to '"
++ key ++ "' in system.config file. Did you forget to run configure?"
path <- askConfigWithDefault key . error $ "\nCannot find path to "
++ quote key ++ " in system.config file. Did you skip configure?"
if null path
then do
if isOptional builder
then return ""
else error $ "Builder '" ++ key ++ "' is not specified in"
else error $ "Builder " ++ quote key ++ " is not specified in"
++ " system.config file. Cannot proceed without it."
else fixAbsolutePathOnWindows =<< lookupInPath path
......
......@@ -11,7 +11,7 @@ newtype ConfigKey = ConfigKey String
askConfig :: String -> Action String
askConfig key = askConfigWithDefault key . error
$ "Cannot find key '" ++ key ++ "' in configuration files."
$ "Cannot find key " ++ quote key ++ " in configuration files."
askConfigWithDefault :: String -> Action String -> Action String
askConfigWithDefault key defaultAction = do
......
......@@ -39,10 +39,10 @@ flag f = do
WithLibdw -> "with-libdw"
UseSystemFfi -> "use-system-ffi"
value <- askConfigWithDefault key . error
$ "\nFlag '" ++ key ++ "' not set in configuration files."
$ "\nFlag " ++ quote key ++ " not set in configuration files."
unless (value == "YES" || value == "NO" || value == "") . error
$ "\nFlag '" ++ key ++ "' is set to '" ++ value
++ "' instead of 'YES' or 'NO'."
$ "\nFlag " ++ quote key ++ " is set to " ++ quote value
++ " instead of 'YES' or 'NO'."
return $ value == "YES"
getFlag :: Flag -> ReaderT a Action Bool
......
......@@ -23,8 +23,8 @@ dependencies path obj = do
$ map (\obj' -> MaybeT $ askOracle $ DependenciesKey (depFile, obj'))
[obj, obj -<.> "o"]
case res of
Nothing -> error $ "No dependencies found for '" ++ obj ++ "'."
Just [] -> error $ "Empty dependency list for '" ++ obj ++ "'."
Nothing -> error $ "No dependencies found for " ++ obj
Just [] -> error $ "Empty dependency list for " ++ obj
Just (src:depFiles) -> return (src, depFiles)
-- Oracle for 'path/dist/.dependencies' files
......
......@@ -161,7 +161,7 @@ runBuilder builder args = do
makeExecutable :: FilePath -> Action ()
makeExecutable file = do
putBuild $ "| Make '" ++ file ++ "' executable."
putBuild $ "| Make " ++ quote file ++ " executable."
quietly $ cmd "chmod +x " [file]
-- | Print out information about the command being executed.
......
......@@ -68,7 +68,7 @@ buildPackageData context@Context {..} = do
, "DEP_EXTRA_LIBS = m"
, "CC_OPTS = " ++ unwords includes ]
writeFileChanged mk contents
putSuccess $ "| Successfully generated '" ++ mk ++ "'."
putSuccess $ "| Successfully generated " ++ mk
when (package == unlit) $ dataFile %> \mk -> do
orderOnly $ generatedDependencies stage package
......@@ -78,7 +78,7 @@ buildPackageData context@Context {..} = do
, "C_SRCS = unlit.c"
, "SYNOPSIS = Literate script filter." ]
writeFileChanged mk contents
putSuccess $ "| Successfully generated '" ++ mk ++ "'."
putSuccess $ "| Successfully generated " ++ mk
when (package == touchy) $ dataFile %> \mk -> do
orderOnly $ generatedDependencies stage package
......@@ -87,7 +87,7 @@ buildPackageData context@Context {..} = do
[ "PROGNAME = touchy"
, "C_SRCS = touchy.c" ]
writeFileChanged mk contents
putSuccess $ "| Successfully generated '" ++ mk ++ "'."
putSuccess $ "| Successfully generated " ++ mk
-- Bootstrapping `ghcCabal`: although `ghcCabal` is a proper cabal
-- package, we cannot generate the corresponding `package-data.mk` file
......@@ -101,7 +101,7 @@ buildPackageData context@Context {..} = do
, "SYNOPSIS = Bootstrapped ghc-cabal utility."
, "HS_SRC_DIRS = ." ]
writeFileChanged mk contents
putSuccess $ "| Successfully generated '" ++ mk ++ "'."
putSuccess $ "| Successfully generated " ++ mk
when (package == rts && stage == Stage1) $ do
dataFile %> \mk -> do
......@@ -128,7 +128,7 @@ buildPackageData context@Context {..} = do
, "CC_OPTS = " ++ unwords includes
, "COMPONENT_ID = rts" ]
writeFileChanged mk contents
putSuccess $ "| Successfully generated '" ++ mk ++ "'."
putSuccess $ "| Successfully generated " ++ mk
-- Prepare a given 'packaga-data.mk' file for parsing by readConfigFile:
-- 1) Drop lines containing '$'
......
......@@ -98,7 +98,7 @@ generate :: FilePath -> Context -> Expr String -> Action ()
generate file context expr = do
contents <- interpretInContext context expr
writeFileChanged file contents
putSuccess $ "| Successfully generated '" ++ file ++ "'."
putSuccess $ "| Successfully generated " ++ file ++ "."
generatePackageCode :: Context -> Rules ()
generatePackageCode context@(Context stage pkg _) =
......@@ -157,7 +157,7 @@ generatePackageCode context@(Context stage pkg _) =
when (pkg == runGhc) $ path -/- "Main.hs" %> \file -> do
copyFileChanged (pkgPath pkg -/- "runghc.hs") file
putSuccess $ "| Successfully generated '" ++ file ++ "'."
putSuccess $ "| Successfully generated " ++ file ++ "."
copyRules :: Rules ()
copyRules = do
......
......@@ -53,7 +53,7 @@ buildPackageLibrary context@Context {..} = do
synopsis <- interpretInContext context $ getPkgData Synopsis
unless isLib0 . putSuccess $ renderLibrary
("'" ++ pkgNameString package ++ "' (" ++ show stage ++ ", way "++ show way ++ ").")
(quote (pkgNameString package) ++ " (" ++ show stage ++ ", way " ++ show way ++ ").")
a
(dropWhileEnd isPunctuation synopsis)
......
......@@ -64,8 +64,8 @@ buildWrapper context@Context {..} wrapper wrapperPath binPath = do
contents <- interpretInContext context $ wrapper binPath
writeFileChanged wrapperPath contents
makeExecutable wrapperPath
putSuccess $ "| Successfully created wrapper for '" ++ pkgNameString package
++ "' (" ++ show stage ++ ")."
putSuccess $ "| Successfully created wrapper for " ++
quote (pkgNameString package) ++ " (" ++ show stage ++ ")."
-- TODO: Get rid of the Paths_hsc2hs.o hack.
-- TODO: Do we need to consider other ways when building programs?
......@@ -102,6 +102,6 @@ buildBinary rs context@(Context stage package _) bin = do
buildWithResources rs $ Target context (Ghc Link stage) binDeps [bin]
synopsis <- interpretInContext context $ getPkgData Synopsis
putSuccess $ renderProgram
("'" ++ pkgNameString package ++ "' (" ++ show stage ++ ").")
(quote (pkgNameString package) ++ " (" ++ show stage ++ ").")
bin
(dropWhileEnd isPunctuation synopsis)
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