1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392
|
\begin{code}
{-# OPTIONS_GHC -cpp #-}
-- copyright (c) 2008 Duncan Coutts
-- portions copyright (c) 2008 David Roundy
import Distribution.Simple
( defaultMainWithHooks, UserHooks(..), simpleUserHooks )
import Distribution.ModuleName( toFilePath )
import Distribution.PackageDescription
( PackageDescription(executables), Executable(buildInfo, exeName)
, BuildInfo(customFieldsBI), emptyBuildInfo
, updatePackageDescription, cppOptions, ccOptions
, library, libBuildInfo, otherModules )
import Distribution.Package
( packageVersion )
import Distribution.Version
( Version(versionBranch) )
import Distribution.Simple.LocalBuildInfo
( LocalBuildInfo(..), absoluteInstallDirs )
import Distribution.Simple.InstallDirs (mandir, CopyDest (NoCopyDest))
import Distribution.Simple.Setup
(buildVerbosity, copyDest, copyVerbosity, fromFlag,
haddockVerbosity, installVerbosity, sDistVerbosity)
import Distribution.Simple.BuildPaths
( autogenModulesDir )
import Distribution.System
( OS(Windows), buildOS )
import Distribution.Simple.Utils
(copyFiles, createDirectoryIfMissingVerbose, rawSystemStdout,
rewriteFile)
import Distribution.Verbosity
( Verbosity )
import Distribution.Text
( display )
import Distribution.Package (Package)
import Control.Monad ( zipWithM_, when, unless, filterM )
import Control.Exception ( bracket )
import System.Directory
(copyFile, createDirectory, createDirectoryIfMissing,
doesDirectoryExist, doesFileExist,
getCurrentDirectory, getDirectoryContents,
removeDirectoryRecursive, removeFile, setCurrentDirectory)
import System.IO (openFile, IOMode (..))
import System.Process (runProcess)
import System.IO.Error ( isDoesNotExistError )
import Data.List( isPrefixOf, isSuffixOf, sort, partition )
import System.FilePath ( (</>), splitDirectories, isAbsolute )
import Foreign.Marshal.Utils ( with )
import Foreign.Storable ( peek )
import Foreign.Ptr ( castPtr )
import Data.Word ( Word8, Word32 )
import qualified Distribution.ShellHarness as Harness ( runTests )
#if __GLASGOW_HASKELL__ >= 610
import qualified Control.OldException as Exception
#else
import qualified Control.Exception as Exception
#endif
main :: IO ()
main = defaultMainWithHooks simpleUserHooks {
buildHook = \ pkg lbi hooks flags ->
let verb = fromFlag $ buildVerbosity flags
in commonBuildHook buildHook pkg lbi hooks verb >>= ($ flags),
haddockHook = \ pkg lbi hooks flags ->
let verb = fromFlag $ haddockVerbosity flags
in commonBuildHook haddockHook pkg lbi hooks verb >>= ($ flags) ,
postBuild = \ _ _ _ lbi -> buildManpage lbi,
postCopy = \ _ flags pkg lbi ->
installManpage pkg lbi (fromFlag $ copyVerbosity flags) (fromFlag $ copyDest flags),
postInst = \ _ flags pkg lbi ->
installManpage pkg lbi (fromFlag $ installVerbosity flags) NoCopyDest,
runTests = \ args _ _ lbi -> do
cwd <- getCurrentDirectory
let isabs = isAbsolute $ buildDir lbi
path = (if isabs then id else (cwd </>))
(buildDir lbi </> "darcs")
what = if null args then ["tests"] else args
(series, tests) = partition
(`elem` ["bugs", "network", "tests"]) what
sequence_ [ case w of
"bugs" -> allTests path Bug []
"network" -> execTests path Network "" []
"tests" -> allTests path Test []
_ -> return () {- impossible, silence -Wall -}
| w <- series ]
when (not $ null tests) $ individualTests path tests,
-- Remove the temporary directories created by "cabal test".
postClean = \ _ _ _ _ -> mapM_ rmRf
["tests-darcs-2.dir",
"tests-hashed.dir",
"tests-old-fashioned-inventory.dir",
"bugs-darcs-2.dir",
"bugs-hashed.dir",
"bugs-old-fashioned-inventory.dir",
"tests-network.dir"],
sDistHook = \ pkg lbi hooks flags -> do
let pkgVer = packageVersion pkg
verb = fromFlag $ sDistVerbosity flags
x <- versionPatches verb pkgVer
y <- context verb pkgVer
rewriteFile "release/distributed-version" $ show x
rewriteFile "release/distributed-context" $ show y
putStrLn "about to hand over"
let pkg' = pkg { library = sanity (library pkg) }
sanity (Just lib) = Just $ lib { libBuildInfo = sanity' $ libBuildInfo lib }
sanity _ = error "eh"
sanity' bi = bi { otherModules = [ m | m <- otherModules bi, toFilePath m /= "Version" ] }
sDistHook simpleUserHooks pkg' lbi hooks flags
}
-- | For @./Setup build@ and @./Setup haddock@, do some unusual
-- things, then invoke the base behaviour ("simple hook").
commonBuildHook :: (UserHooks -> PackageDescription -> LocalBuildInfo -> t -> a)
-> PackageDescription -> LocalBuildInfo -> t -> Verbosity -> IO a
commonBuildHook runHook pkg lbi hooks verbosity = do
(version, state) <- determineVersion verbosity pkg
-- Create our own context file.
generateVersionModule verbosity pkg lbi version state
-- Add custom -DFOO[=BAR] flags to the cpp (for .hs) and cc (for .c)
-- invocations, doing a dance to make the base hook aware of them.
littleEndian <- testEndianness
let args = ("-DPACKAGE_VERSION=" ++ show' version) :
("-DPACKAGE_VERSION_STATE=" ++ show' state) :
[arg | (arg, True) <- -- include fst iff snd.
[("-DHAVE_HTTP", "x-have-http" `elem` customFields),
("-DUSE_COLOR", "x-use-color" `elem` customFields),
-- We have MAPI iff building on/for Windows.
("-DHAVE_MAPI", buildOS == Windows),
("-DBIGENDIAN", not littleEndian)]]
bi = emptyBuildInfo { cppOptions = args, ccOptions = args }
hbi = (Just bi, [(exeName exe, bi) | exe <- executables pkg])
pkg' = updatePackageDescription hbi pkg
lbi' = lbi { localPkgDescr = pkg' }
return $ runHook simpleUserHooks pkg' lbi' hooks
where
customFields = map fst . customFieldsBI . buildInfo $ darcsExe
darcsExe = head [e | e <- executables pkg, exeName e == "darcs"]
show' :: String -> String -- Petr was worried that we might
show' = show -- allow non-String arguments.
testEndianness :: IO Bool
testEndianness = with (1 :: Word32) $ \p -> do o <- peek $ castPtr p
return $ o == (1 :: Word8)
buildManpage :: LocalBuildInfo -> IO ()
buildManpage lbi = do
let darcs = buildDir lbi </> "darcs/darcs"
manpage = buildDir lbi </> "darcs/darcs.1"
manpageHandle <- openFile manpage WriteMode
runProcess darcs ["help","manpage"]
Nothing Nothing Nothing (Just manpageHandle) Nothing
return ()
installManpage :: PackageDescription -> LocalBuildInfo
-> Verbosity -> CopyDest -> IO ()
installManpage pkg lbi verbosity copy =
copyFiles verbosity
(mandir (absoluteInstallDirs pkg lbi copy) </> "man1")
[(buildDir lbi </> "darcs", "darcs.1")]
determineVersion :: Verbosity -> PackageDescription -> IO (String, String)
determineVersion verbosity pkg = do
let darcsVersion = packageVersion pkg
numPatches <- versionPatches verbosity darcsVersion
return (display darcsVersion, versionStateString numPatches darcsVersion)
where
versionStateString :: Maybe Int -> Version -> String
versionStateString Nothing _ = "unknown"
versionStateString (Just 0) v = case versionBranch v of
x | 97 `elem` x -> "alpha " ++ show (after 97 x)
| 98 `elem` x -> "beta " ++ show (after 98 x)
| 99 `elem` x ->
"release candidate " ++ show (after 99 x)
_ -> "release"
versionStateString (Just 1) _ = "+ 1 patch"
versionStateString (Just n) _ = "+ " ++ show n ++ " patches"
after w (x:r) | w == x = head r
| otherwise = after w r
after _ [] = undefined
versionPatches :: Verbosity -> Version -> IO (Maybe Int)
versionPatches verbosity darcsVersion = do
numPatchesDarcs <- do
out <- rawSystemStdout verbosity "darcs"
["changes", "--from-tag", display darcsVersion, "--count"]
case reads (out) of
((n,_):_) -> return $ Just ((n :: Int) - 1)
_ -> return Nothing
`Exception.catch` \_ -> return Nothing
numPatchesDist <- parseFile versionFile
return $ case (numPatchesDarcs, numPatchesDist) of
(Just x, _) -> Just x
(Nothing, Just x) -> Just x
(Nothing, Nothing) -> Nothing
where
versionFile = "release/distributed-version"
generateVersionModule :: Verbosity -> PackageDescription -> LocalBuildInfo
-> String -> String -> IO ()
generateVersionModule verbosity pkg lbi version state = do
let dir = autogenModulesDir lbi
createDirectoryIfMissingVerbose verbosity True dir
ctx <- context verbosity (packageVersion pkg)
rewriteFile (dir </> "Version.hs") $ unlines
["module Version where"
,"version, context :: String"
,"version = \"" ++ version ++ " (" ++ state ++ ")\""
,"context = " ++ case ctx of
Just x -> show x
Nothing -> show "context not available"
]
context :: Verbosity -> Version -> IO (Maybe String)
context verbosity version = do
contextDarcs <- do
-- FIXME currently we run changes --from-tag to at least assert that the
-- requested version is tagged in this repository... it is a weak check,
-- but otherwise, my ~/_darcs context tends to gets used when running
-- from an unpacked distribution
rawSystemStdout verbosity "darcs"
["changes", "--from-tag", display version ]
out <- rawSystemStdout verbosity "darcs" ["changes", "--context"]
return $ Just out
`Exception.catch` \_ -> return Nothing
contextDist <- parseFile contextFile
return $ case (contextDarcs, contextDist) of
(Just x, _) -> Just x
(Nothing, Just x) -> Just x
(Nothing, Nothing) -> Nothing
where contextFile = "release/distributed-context"
parseFile :: (Read a) => String -> IO (Maybe a)
parseFile f = do
exist <- doesFileExist f
if exist then do
content <- readFile f -- ^ ratify readFile: we don't care here.
case reads content of
((s,_):_) -> return s
_ -> return Nothing
else return Nothing
-------------------------------------
-- Running the testsuite
--
data TestKind = Bug | Test | Network deriving Eq
testDir :: TestKind -> String
testDir Bug = "tests"
testDir Test = "tests"
testDir Network = "tests/network"
deslash :: Char -> Char
deslash '/' = '-'
deslash x = x
isSh :: FilePath -> Bool
isSh = (".sh" `isSuffixOf`)
-- | By convention, a test script starts with "failing-" iff it is
-- expected to fail, i.e. it is a bug that hasn't been fixed yet.
isTest :: TestKind -> FilePath -> Bool
isTest Bug = ("failing-" `isPrefixOf`)
isTest _ = not . isTest Bug
execTests :: FilePath -> TestKind -> String -> [String] -> IO ()
execTests darcs_path k fmt tests = do
let dir = map deslash (testDir k) ++ (if null fmt then fmt else "-" ++ fmt) ++ ".dir"
rmRf dir
cloneTree (testDir k) dir
withCurrentDirectory dir $ do
createDirectory ".darcs"
when (not $ null fmt) $ appendFile ".darcs/defaults" $ "ALL " ++ fmt ++ "\n"
putStrLn $ "Running tests for format: " ++ fmt
fs <- case tests of
[] -> sort `fmap` getDirectoryContents "."
x -> return x
let run = filter (\f -> isSh f && isTest k f) fs
cwd <- getCurrentDirectory
res <- Harness.runTests (Just darcs_path) cwd run
when ((not res) && (k /= Bug)) $ fail "Tests failed"
return ()
individualTests :: FilePath -> [String] -> IO ()
individualTests darcs_path tests = do
run <- concat `fmap` mapM find tests
sequence_ [ do exec kind [test | (kind', test) <- run, kind' == kind]
| kind <- [Test, Bug, Network] ]
where tryin w t' = [w </> t', w </> (t' ++ ".sh")]
exec _ [] = return ()
exec kind to_run = allTests darcs_path kind to_run
find t = do
let c = [t, t ++ ".sh"] ++ tryin "tests" t
++ tryin "network" t
run <- map kindify `fmap` filterM doesFileExist c
return $ take 1 run
kindify test = case splitDirectories test of
[p, y] -> (parse_kind p y, y)
_ -> error $ "Bad format in " ++ test ++
": expected type/test"
parse_kind "tests" y = if isTest Bug y then Bug else Test
parse_kind "network" _ = Network
parse_kind x _ = error $ "Test prefix must be one of " ++
"[tests, network] in " ++ x
allTests :: FilePath -> TestKind -> [String] -> IO ()
allTests darcs_path k s =
do test `mapM` repotypes
return ()
where repotypes = ["darcs-2", "hashed", "old-fashioned-inventory"]
test x = execTests darcs_path k x s
-------------------------------------------------------
-- Utility functions (FIXME)
-- copy & paste & edit: darcs wants to share these
--
withCurrentDirectory :: FilePath -> IO a -> IO a
withCurrentDirectory name m =
bracket
(do cwd <- getCurrentDirectory
when (name /= "") (setCurrentDirectory name)
return cwd)
(\oldwd -> setCurrentDirectory oldwd `catch` (\_ -> return ()))
(const m)
cloneTree :: FilePath -> FilePath -> IO ()
cloneTree = cloneTreeExcept []
cloneTreeExcept :: [FilePath] -> FilePath -> FilePath -> IO ()
cloneTreeExcept except source dest =
do isdir <- doesDirectoryExist source
if isdir then do
createDirectoryIfMissing True dest
fps <- getDirectoryContents source
let fps' = filter (`notElem` (".":"..":except)) fps
mk_source fp = source ++ "/" ++ fp
mk_dest fp = dest ++ "/" ++ fp
zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')
else fail ("cloneTreeExcept: Bad source " ++ source)
`catch` fail ("cloneTreeExcept: Bad source " ++ source)
cloneSubTree :: FilePath -> FilePath -> IO ()
cloneSubTree source dest =
do isdir <- doesDirectoryExist source
isfile <- doesFileExist source
if isdir then do
createDirectory dest
fps <- getDirectoryContents source
let fps' = filter (`notElem` [".", ".."]) fps
mk_source fp = source ++ "/" ++ fp
mk_dest fp = dest ++ "/" ++ fp
zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')
else if isfile then do
cloneFile source dest
else fail ("cloneSubTree: Bad source "++ source)
`catch` (\e -> if isDoesNotExistError e
then return ()
else ioError e)
cloneFile :: FilePath -> FilePath -> IO ()
cloneFile = copyFile
rmRf :: FilePath -> IO ()
rmRf path = do
isdir <- doesDirectoryExist path
isf <- doesFileExist path
when isdir $ removeDirectoryRecursive path
when isf $ removeFile path
return ()
-- (END FIXME)
\end{code}
|