diff --git a/DDC/War/Config.hs b/DDC/War/Config.hs --- a/DDC/War/Config.hs +++ b/DDC/War/Config.hs @@ -39,7 +39,7 @@ { T.specTestDirs = [] , T.specWays = [] , T.specThreads = 1 - , T.specFormatPathWidth = 70 + , T.specFormatPathWidth = 80 , T.specInteractive = True , T.specResultsFileAll = Nothing , T.specResultsFileFailed = Nothing } @@ -52,12 +52,13 @@ , N.specRemoteSnapshotURL = "http://code.ouroborus.net/ddc/snapshot/ddc-head-latest.tgz" , N.specRemoteRepoURL = "http://code.ouroborus.net/ddc/ddc-head" , N.specBuildThreads = 1 + , N.specBuildFlavour = "distro" , N.specCleanup = False , N.specContinuous = Nothing , N.specNow = False , N.specLogUserHost = Just $ "overlord@deluge.ouroborus.net" - , N.specLogRemoteDir = Just $ "log/desire/ddc/head" - , N.specLogRemoteURL = Just $ "http://log.ouroborus.net/desire/ddc/head" + , N.specLogRemoteDir = Nothing + , N.specLogRemoteURL = Nothing , N.specMailer = Just $ B.MailerSendmail "sendmail" [] , N.specMailFrom = Just $ "DDC Buildbot " , N.specMailTo = Just $ "disciple-cafe@googlegroups.com" } diff --git a/DDC/War/Create.hs b/DDC/War/Create.hs --- a/DDC/War/Create.hs +++ b/DDC/War/Create.hs @@ -25,6 +25,9 @@ -- Test.dcx Run with ddci-core. -- Test.stdout.check Diff run stdout with this file. -- +-- Test.dsx Run with ddci-tetra. +-- Test.stdout.check Diff run stdout with this file. +-- module DDC.War.Create ( Way (..) , create) @@ -38,7 +41,8 @@ import qualified DDC.War.Create.CreateMainDS as CreateMainDS import qualified DDC.War.Create.CreateTestDS as CreateTestDS import qualified DDC.War.Create.CreateDCX as CreateDCX -import qualified DDC.War.Create.CreateDCE as CreateDCE +import qualified DDC.War.Create.CreateDSX as CreateDSX +import qualified DDC.War.Create.CreateDC as CreateDC -- | Create job chains based on this file. @@ -56,5 +60,6 @@ , CreateMainDS.create , CreateTestDS.create , CreateDCX.create - , CreateDCE.create ]] + , CreateDSX.create + , CreateDC.create ]] diff --git a/DDC/War/Create/CreateDC.hs b/DDC/War/Create/CreateDC.hs new file mode 100644 --- /dev/null +++ b/DDC/War/Create/CreateDC.hs @@ -0,0 +1,97 @@ + + +module DDC.War.Create.CreateDC + (create) +where +import DDC.War.Create.Way +import DDC.War.Driver +import System.FilePath +import DDC.War.Job () +import Data.Set (Set) +import qualified DDC.War.Job.CompileDC as CompileDC +import qualified DDC.War.Job.RunExe as RunExe +import qualified DDC.War.Job.Diff as Diff +import qualified Data.Set as Set + + +-- | Compile and run .dce files. +create :: Way -> Set FilePath -> FilePath -> Maybe Chain +create way allFiles filePath + | takeFileName filePath == "Main.dcs" + || takeFileName filePath == "Main.dcl" + = let + sourceDir = takeDirectory filePath + buildDir = sourceDir "war-" ++ wayName way + testName = filePath + + mainSH = sourceDir "Main.sh" + mainBin = buildDir "Main.bin" + mainCompStdout = buildDir "Main.compile.stdout" + mainCompStderr = buildDir "Main.compile.stderr" + mainCompDiff = buildDir "Main.compile.stderr.diff" + mainRunStdout = buildDir "Main.run.stdout" + mainRunStderr = buildDir "Main.run.stderr" + + mainErrorCheck = sourceDir "Main.error.check" + compShouldSucceed = not $ Set.member mainErrorCheck allFiles + + -- If this exists then expect the execuable to fail at runtime. + mainRunErrorCheck = sourceDir "Main.runerror.check" + runShouldSucceed = not $ Set.member mainRunErrorCheck allFiles + + mainStdoutCheck = sourceDir "Main.stdout.check" + mainStdoutDiff = buildDir "Main.run.stdout.diff" + shouldDiffStdout = Set.member mainStdoutCheck allFiles + + mainStderrCheck = sourceDir "Main.stderr.check" + mainStderrDiff = buildDir "Main.run.stderr.diff" + shouldDiffStderr = Set.member mainStderrCheck allFiles + + fragment + | takeExtension filePath == "dcs" = CompileDC.FragmentSalt + | takeExtension filePath == "dcl" = CompileDC.FragmentLite + | otherwise = error "ddc-war.create: bad fragment" + + -- compile the .ds into a .bin + compile = jobOfSpec (JobId testName (wayName way)) + $ CompileDC.Spec + filePath (wayOptsComp way) fragment + buildDir mainCompStdout mainCompStderr + (Just mainBin) compShouldSucceed + + -- run the binary + run = jobOfSpec (JobId testName (wayName way)) + $ RunExe.Spec + filePath + mainBin [] + mainRunStdout mainRunStderr + runShouldSucceed + + -- diff errors produced by the compilation + diffError = jobOfSpec (JobId testName (wayName way)) + $ Diff.Spec + mainErrorCheck + mainCompStderr mainCompDiff + + -- diff the stdout of the run + diffStdout = jobOfSpec (JobId testName (wayName way)) + $ Diff.Spec + mainStdoutCheck + mainRunStdout mainStdoutDiff + + -- diff the stderr of the run + diffStderr = jobOfSpec (JobId testName (wayName way)) + $ Diff.Spec + mainStderrCheck + mainRunStderr mainStderrDiff + + in if Set.member mainSH allFiles + then Nothing + else Just $ Chain + $ [compile] + ++ (if compShouldSucceed then [run] else [diffError]) + ++ (if shouldDiffStdout then [diffStdout] else []) + ++ (if shouldDiffStderr then [diffStderr] else []) + + | otherwise = Nothing + diff --git a/DDC/War/Create/CreateDCE.hs b/DDC/War/Create/CreateDCE.hs deleted file mode 100644 --- a/DDC/War/Create/CreateDCE.hs +++ /dev/null @@ -1,87 +0,0 @@ - - -module DDC.War.Create.CreateDCE - (create) -where -import DDC.War.Create.Way -import DDC.War.Driver -import System.FilePath -import DDC.War.Job () -import Data.Set (Set) -import qualified DDC.War.Job.CompileDCE as CompileDCE -import qualified DDC.War.Job.RunExe as RunExe -import qualified DDC.War.Job.Diff as Diff -import qualified Data.Set as Set - - --- | Compile and run .dce files. -create :: Way -> Set FilePath -> FilePath -> Maybe Chain -create way allFiles filePath - | takeFileName filePath == "Main.dce" - = let - sourceDir = takeDirectory filePath - buildDir = sourceDir "war-" ++ wayName way - testName = filePath - - mainSH = sourceDir "Main.sh" - mainBin = buildDir "Main.bin" - mainCompStdout = buildDir "Main.compile.stdout" - mainCompStderr = buildDir "Main.compile.stderr" - mainCompDiff = buildDir "Main.compile.stderr.diff" - mainRunStdout = buildDir "Main.run.stdout" - mainRunStderr = buildDir "Main.run.stderr" - - mainErrorCheck = sourceDir "Main.error.check" - shouldSucceed = not $ Set.member mainErrorCheck allFiles - - mainStdoutCheck = sourceDir "Main.stdout.check" - mainStdoutDiff = buildDir "Main.run.stdout.diff" - shouldDiffStdout = Set.member mainStdoutCheck allFiles - - mainStderrCheck = sourceDir "Main.stderr.check" - mainStderrDiff = buildDir "Main.run.stderr.diff" - shouldDiffStderr = Set.member mainStderrCheck allFiles - - -- compile the .ds into a .bin - compile = jobOfSpec (JobId testName (wayName way)) - $ CompileDCE.Spec - filePath - buildDir mainCompStdout mainCompStderr - (Just mainBin) shouldSucceed - - -- run the binary - run = jobOfSpec (JobId testName (wayName way)) - $ RunExe.Spec - filePath - mainBin [] - mainRunStdout mainRunStderr - True - - -- diff errors produced by the compilation - diffError = jobOfSpec (JobId testName (wayName way)) - $ Diff.Spec - mainErrorCheck - mainCompStderr mainCompDiff - - -- diff the stdout of the run - diffStdout = jobOfSpec (JobId testName (wayName way)) - $ Diff.Spec - mainStdoutCheck - mainRunStdout mainStdoutDiff - - -- diff the stderr of the run - diffStderr = jobOfSpec (JobId testName (wayName way)) - $ Diff.Spec - mainStderrCheck - mainRunStderr mainStderrDiff - - in if Set.member mainSH allFiles - then Nothing - else Just $ Chain - $ [compile] - ++ (if shouldSucceed then [run] else [diffError]) - ++ (if shouldDiffStdout then [diffStdout] else []) - ++ (if shouldDiffStderr then [diffStderr] else []) - - | otherwise = Nothing - diff --git a/DDC/War/Create/CreateDSX.hs b/DDC/War/Create/CreateDSX.hs new file mode 100644 --- /dev/null +++ b/DDC/War/Create/CreateDSX.hs @@ -0,0 +1,46 @@ + +module DDC.War.Create.CreateDSX + (create) +where +import DDC.War.Create.Way +import DDC.War.Driver +import System.FilePath +import DDC.War.Job () +import Data.Set (Set) +import qualified DDC.War.Job.RunDSX as RunDSX +import qualified DDC.War.Job.Diff as Diff +import qualified Data.Set as Set + + +-- | Run .dcx files with the interpreter. +create :: Way -> Set FilePath -> FilePath -> Maybe Chain +create way allFiles filePath + | takeFileName filePath == "Test.dsx" + = let + fileName = takeFileName filePath + sourceDir = takeDirectory filePath + buildDir = sourceDir "war-" ++ wayName way + testName = filePath + + testDDCiStdout = buildDir replaceExtension fileName ".ddci-tetra.stdout" + testDDCiStderr = buildDir replaceExtension fileName ".ddci-tetra.stderr" + + testStdoutCheck = sourceDir "Test.stdout.check" + testStdoutDiff = buildDir "Test.stdout.check.diff" + shouldDiffStdout = Set.member testStdoutCheck allFiles + + jobRun = jobOfSpec (JobId testName (wayName way)) + $ RunDSX.Spec + filePath + buildDir testDDCiStdout testDDCiStderr + + jobDiff = jobOfSpec (JobId testName (wayName way)) + $ Diff.Spec + testStdoutCheck + testDDCiStdout testStdoutDiff + + in Just $ Chain + $ [jobRun] + ++ (if shouldDiffStdout then [jobDiff] else []) + + | otherwise = Nothing diff --git a/DDC/War/Driver/Gang.hs b/DDC/War/Driver/Gang.hs --- a/DDC/War/Driver/Gang.hs +++ b/DDC/War/Driver/Gang.hs @@ -41,8 +41,7 @@ -> IO () runChainIO tmpDir mChanResult ixChain chain - = do uid <- getUniqueId -- TODO: buildbox should handle this - -- should not need process id. + = do uid <- getUniqueId let state = buildStateDefault uid tmpDir runBuildWithState state diff --git a/DDC/War/Interface/Controller.hs b/DDC/War/Interface/Controller.hs --- a/DDC/War/Interface/Controller.hs +++ b/DDC/War/Interface/Controller.hs @@ -15,7 +15,7 @@ import Data.Maybe import Data.List import DDC.War.Interface.VT100 as VT100 -import qualified System.Cmd +import qualified System.Process data Config @@ -167,7 +167,7 @@ -- Bogus pattern match to avoid warning. | otherwise - = error "DDC.War.Interface.Controller.handleResult: no match" + = error "ddc-war.handleResult: no match" handleResult_askDiff :: FilePath -> FilePath -> FilePath -> IO Bool @@ -202,7 +202,7 @@ -- Update the expected output with the actual one | ('u': _) <- cmd - = do System.Cmd.system + = do System.Process.system $ "cp " ++ fileOut ++ " " ++ fileRef return True diff --git a/DDC/War/Job.hs b/DDC/War/Job.hs --- a/DDC/War/Job.hs +++ b/DDC/War/Job.hs @@ -2,21 +2,22 @@ {-# OPTIONS -fno-warn-orphans #-} module DDC.War.Job where import DDC.War.Driver.Base -import qualified DDC.War.Job.CompileDCE as CompileDCE +import qualified DDC.War.Job.CompileDC as CompileDC import qualified DDC.War.Job.CompileDS as CompileDS import qualified DDC.War.Job.CompileHS as CompileHS import qualified DDC.War.Job.Diff as Diff import qualified DDC.War.Job.RunDCX as RunDCX +import qualified DDC.War.Job.RunDSX as RunDSX import qualified DDC.War.Job.RunExe as RunExe import qualified DDC.War.Job.Shell as Shell import BuildBox.Pretty -instance Spec CompileDCE.Spec CompileDCE.Result where +instance Spec CompileDC.Spec CompileDC.Result where specActionName _ = "compile" - buildFromSpec = CompileDCE.build + buildFromSpec = CompileDC.build productOfResult _ result - = ProductStatus (ppr result) (CompileDCE.resultSuccess result) + = ProductStatus (ppr result) (CompileDC.resultSuccess result) instance Spec CompileDS.Spec CompileDS.Result where @@ -50,6 +51,13 @@ buildFromSpec = RunDCX.build productOfResult _ result = ProductStatus (ppr result) (RunDCX.resultSuccess result) + + +instance Spec RunDSX.Spec RunDSX.Result where + specActionName _ = "run" + buildFromSpec = RunDSX.build + productOfResult _ result + = ProductStatus (ppr result) (RunDSX.resultSuccess result) instance Spec RunExe.Spec RunExe.Result where diff --git a/DDC/War/Job/CompileDC.hs b/DDC/War/Job/CompileDC.hs new file mode 100644 --- /dev/null +++ b/DDC/War/Job/CompileDC.hs @@ -0,0 +1,159 @@ + +module DDC.War.Job.CompileDC + ( Spec (..) + , Fragment (..) + , Result (..) + , resultSuccess + , build) +where +import BuildBox.Command.File +import BuildBox.Command.System +import BuildBox.Build.Benchmark +import BuildBox.Data.Physical +import BuildBox.IO.Directory +import BuildBox.Pretty +import BuildBox +import System.FilePath +import qualified System.FilePath.Posix as P +import System.Directory +import Control.Monad +import Data.List + + +-- | Use ddci-core to compile/make file a DCE file +data Spec + = Spec + { -- | Root source file of the program (the 'Main.ds') + specFile :: FilePath + + -- | Extra DDC options for building in this way. + , specOptionsDDC :: [String] + + -- | Language fragment. + , specFragment :: Fragment + + -- | Scratch dir to do the build in. + , specScratchDir :: String + + -- | Put what DDC says to stdout here. + , specCompileStdout :: FilePath + + -- | Put what DDC says to stderr here. + , specCompileStderr :: FilePath + + -- | If Just, then we're making an executable, and put the binary here. + -- Otherwise simply compile it + , specMaybeMainBin :: Maybe FilePath + + -- | True if the compile is expected to succeed, else not. + , specShouldSucceed :: Bool } + deriving Show + + +-- | Language fragments that we can compile. +data Fragment + = FragmentSalt -- File.dce + | FragmentLite -- File.dcl + deriving Show + + +-- | Result of a compilation test. +data Result + = ResultSuccess Seconds + | ResultUnexpectedFailure + | ResultUnexpectedSuccess + deriving Show + + +resultSuccess :: Result -> Bool +resultSuccess result + = case result of + ResultSuccess{} -> True + _ -> False + + +instance Pretty Result where + ppr result + = case result of + ResultSuccess seconds -> text "success" <+> parens (ppr seconds) + ResultUnexpectedFailure -> text "failed" + ResultUnexpectedSuccess -> text "unexpected" + + +-- Build ---------------------------------------------------------------------- +-- | Compile a Disciple Core Sea source file. +build :: Spec -> Build Result +build (Spec srcDC_ optionsDDC _fragment + buildDir mainCompOut mainCompErr + mMainBin shouldSucceed) + + = do let ddcExe = "bin/ddc" <.> exe + + needs srcDC_ + needs ddcExe + + ddcBin <- io $ canonicalizePath ddcExe + + -- Normalise the file name relative to the current directory + -- so that error messages don't change between hosts. + srcDC' <- io $ makeRelativeToCurrentDirectory srcDC_ + + -- Make the file path use consistent path separators across all hosts. + let srcDC = flip map srcDC' $ + \c -> if isPathSeparator c + then P.pathSeparator + else c + + -- The directory holding the Main.dce file. + let (srcDir, _srcFile) = splitFileName srcDC + + -- Touch the .dce and .dcl files to the build directory to ensure they're built. + sources <- io + $ liftM (filter (\f -> isSuffixOf ".dcs" f || isSuffixOf ".dcl" f)) + $ lsFilesIn srcDir + + ssystemq $ "touch " ++ (intercalate " " sources) + + -- ensure the output directory exists + ensureDir buildDir + + -- Do the compile. + let compile + | Just mainBin <- mMainBin + = do -- If there is an existing binary then remove it. + ssystemq $ "rm -f " ++ mainBin + + -- Build the program. + timeBuild + $ systemTee False + (ddcBin + ++ " " ++ intercalate " " optionsDDC + ++ " -output " ++ mainBin + ++ " -output-dir " ++ buildDir + ++ " -make " ++ srcDC) + "" + + -- Compile the program. + | otherwise + = do timeBuild + $ systemTee False + (ddcBin + ++ " " ++ intercalate " " optionsDDC + ++ " -output-dir " ++ buildDir + ++ " -compile " ++ srcDC) + "" + (time, (code, strOut, strErr)) + <- compile + + atomicWriteFile mainCompOut strOut + atomicWriteFile mainCompErr strErr + + case code of + ExitFailure _ + | shouldSucceed -> return ResultUnexpectedFailure + + ExitSuccess + | not shouldSucceed -> return ResultUnexpectedSuccess + + _ -> return $ ResultSuccess time + diff --git a/DDC/War/Job/CompileDCE.hs b/DDC/War/Job/CompileDCE.hs deleted file mode 100644 --- a/DDC/War/Job/CompileDCE.hs +++ /dev/null @@ -1,125 +0,0 @@ - -module DDC.War.Job.CompileDCE - ( Spec (..) - , Result(..) - , resultSuccess - , build) -where -import BuildBox.Command.File -import BuildBox.Command.System -import BuildBox.Build.Benchmark -import BuildBox.Data.Physical -import BuildBox.IO.Directory -import BuildBox.Pretty -import BuildBox -import System.FilePath -import Control.Monad -import Data.List - - --- | Use ddci-core to compile/make file a DCE file -data Spec - = Spec - { -- | Root source file of the program (the 'Main.ds') - specFile :: FilePath - - -- | Scratch dir to do the build in. - , specScratchDir :: String - - -- | Put what DDC says to stdout here. - , specCompileStdout :: FilePath - - -- | Put what DDC says to stderr here. - , specCompileStderr :: FilePath - - -- | If Just, then we're making an executable, and put the binary here. - -- Otherwise simply compile it - , specMaybeMainBin :: Maybe FilePath - - -- | True if the compile is expected to succeed, else not. - , specShouldSucceed :: Bool } - deriving Show - - -data Result - = ResultSuccess Seconds - | ResultUnexpectedFailure - | ResultUnexpectedSuccess - deriving Show - -resultSuccess :: Result -> Bool -resultSuccess result - = case result of - ResultSuccess{} -> True - _ -> False - - -instance Pretty Result where - ppr result - = case result of - ResultSuccess seconds -> text "success" <+> parens (ppr seconds) - ResultUnexpectedFailure -> text "failed" - ResultUnexpectedSuccess -> text "unexpected" - - --- Build ---------------------------------------------------------------------- --- | Compile a Disciple Core Sea source file. -build :: Spec -> Build Result -build (Spec srcDCE - buildDir mainCompOut mainCompErr - mMainBin shouldSucceed) - - = do needs srcDCE - needs "bin/ddci-core" - - -- The directory holding the Main.dce file. - let (srcDir, _srcFile) = splitFileName srcDCE - - -- Touch the .dce files to the build directory to ensure they're built. - sources <- io - $ liftM (filter (\f -> isSuffixOf ".dce" f)) - $ lsFilesIn srcDir - - ssystemq $ "touch " ++ (intercalate " " sources) - - -- ensure the output directory exists - ensureDir buildDir - - -- Do the compile. - let compile - | Just mainBin <- mMainBin - = do -- If there is an existing binary then remove it. - ssystemq $ "rm -f " ++ mainBin - - -- Build the program. - timeBuild - $ systemTee False - ("bin/ddci-core" - ++ " -set output " ++ mainBin - ++ " -set outputdir " ++ buildDir - ++ " -make " ++ srcDCE) - "" - - -- Compile the program. - | otherwise - = do timeBuild - $ systemTee False - ("bin/ddci-core" - ++ " -set outputdir " ++ buildDir - ++ " -compile " ++ srcDCE) - "" - (time, (code, strOut, strErr)) - <- compile - - atomicWriteFile mainCompOut strOut - atomicWriteFile mainCompErr strErr - - case code of - ExitFailure _ - | shouldSucceed -> return ResultUnexpectedFailure - - ExitSuccess - | not shouldSucceed -> return ResultUnexpectedSuccess - - _ -> return $ ResultSuccess time - diff --git a/DDC/War/Job/CompileDS.hs b/DDC/War/Job/CompileDS.hs --- a/DDC/War/Job/CompileDS.hs +++ b/DDC/War/Job/CompileDS.hs @@ -74,8 +74,10 @@ buildDir mainCompOut mainCompErr mMainBin shouldSucceed) - = do needs srcDS - needs "bin/ddc" + = do let ddcaExe = "bin/ddc-alpha" <.> exe + + needs srcDS + needs ddcaExe -- The directory holding the Main.ds file. let (srcDir, _srcFile) = splitFileName srcDS @@ -100,7 +102,7 @@ -- Build the program. timeBuild $ systemTee False - ("bin/ddc" + (ddcaExe ++ " -v -make " ++ srcDS ++ " -o " ++ mainBin ++ " -outputdir " ++ buildDir @@ -113,7 +115,7 @@ | otherwise = do timeBuild $ systemTee False - ("bin/ddc" + (ddcaExe ++ " -c " ++ srcDS ++ " -outputdir " ++ buildDir ++ " " ++ intercalate " " optionsDDC diff --git a/DDC/War/Job/CompileHS.hs b/DDC/War/Job/CompileHS.hs --- a/DDC/War/Job/CompileHS.hs +++ b/DDC/War/Job/CompileHS.hs @@ -114,6 +114,7 @@ = do let str = "# Generated Makefile\n\n" ++ "include make/build.mk\n\n" ++ mainBin ++ " : " ++ mainHs ++ "\n" - ++ "\t$(GHC) $(GHC_LANGUAGE) $(DDC_PACKAGES) -ipackages/ddc-main --make $^ -o $@\n\n" + ++ "\t$(GHC) $(GHC_LANGUAGE) $(DDC_PACKAGES)" + ++ " -ipackages/ddc-alpha/src -ipackages/ddc-core-llvm --make $^ -o $@\n\n" io $ writeFile outfile str diff --git a/DDC/War/Job/Diff.hs b/DDC/War/Job/Diff.hs --- a/DDC/War/Job/Diff.hs +++ b/DDC/War/Job/Diff.hs @@ -60,7 +60,7 @@ -- Run the binary. (_code, strOut, _strErr) <- systemTee False - (diffExe ++ " " ++ fileRef ++ " " ++ fileOut) + (diffExe ++ " --ignore-space-change " ++ fileRef ++ " " ++ fileOut) "" -- Write its output to file. diff --git a/DDC/War/Job/RunDCX.hs b/DDC/War/Job/RunDCX.hs --- a/DDC/War/Job/RunDCX.hs +++ b/DDC/War/Job/RunDCX.hs @@ -12,6 +12,7 @@ import BuildBox.Pretty import BuildBox import System.Directory +import System.FilePath -- | Feed a file into DDCi-core @@ -56,13 +57,15 @@ build (Spec srcDCX buildDir testRunStdout testRunStderr) - = do needs srcDCX - needs "bin/ddci-core" + = do let ddciExe = "bin/ddci-core" <.> exe + needs srcDCX + needs ddciExe + -- ensure the output directory exists ensureDir buildDir - ddciBin' <- io $ canonicalizePath "bin/ddci-core" + ddciBin' <- io $ canonicalizePath ddciExe (time, (code, strOut, strErr)) <- timeBuild diff --git a/DDC/War/Job/RunDSX.hs b/DDC/War/Job/RunDSX.hs new file mode 100644 --- /dev/null +++ b/DDC/War/Job/RunDSX.hs @@ -0,0 +1,81 @@ + +module DDC.War.Job.RunDSX + ( Spec (..) + , Result (..) + , resultSuccess + , build) +where +import BuildBox.Command.File +import BuildBox.Command.System +import BuildBox.Build.Benchmark +import BuildBox.Data.Physical +import BuildBox.Pretty +import BuildBox +import System.Directory +import System.FilePath + + +-- | Feed a file into DDCi-tetra +data Spec + = Spec + { -- | Root source file of the program (the 'Main.ds') + specFile :: FilePath + + -- | Scratch dir to do the build in. + , specScratchDir :: String + + -- | Put what DDC says to stdout here. + , specCompileStdout :: FilePath + + -- | Put what DDC says to stderr here. + , specCompileStderr :: FilePath } + deriving Show + + +data Result + = ResultSuccess Seconds + | ResultFailure + deriving Show + + +resultSuccess :: Result -> Bool +resultSuccess result + = case result of + ResultSuccess{} -> True + _ -> False + + +instance Pretty Result where + ppr result + = case result of + ResultSuccess seconds -> text "success" <+> parens (ppr seconds) + ResultFailure -> text "failed" + + +-- | Compile a Haskell Source File +build :: Spec -> Build Result +build (Spec srcDSX + buildDir testRunStdout testRunStderr) + + = do let ddciExe = "bin/ddci-tetra" <.> exe + + needs srcDSX + needs ddciExe + + -- ensure the output directory exists + ensureDir buildDir + + ddciBin' <- io $ canonicalizePath ddciExe + + (time, (code, strOut, strErr)) + <- timeBuild + $ systemTee False + (ddciBin' ++ " --batch " ++ srcDSX) + "" + atomicWriteFile testRunStdout strOut + atomicWriteFile testRunStderr strErr + + case code of + ExitSuccess -> return $ ResultSuccess time + _ -> return $ ResultFailure + diff --git a/DDC/War/Option.hs b/DDC/War/Option.hs --- a/DDC/War/Option.hs +++ b/DDC/War/Option.hs @@ -114,6 +114,9 @@ , t > 0 = eatn more $ spec { N.specBuildThreads = t} + | "-build-flavour" : flavour : more <- args + = eatn more $ spec { N.specBuildFlavour = flavour } + eatn (arg : _) _ = Left arg diff --git a/DDC/War/Task/Nightly.hs b/DDC/War/Task/Nightly.hs --- a/DDC/War/Task/Nightly.hs +++ b/DDC/War/Task/Nightly.hs @@ -33,9 +33,12 @@ -- | URL of DDC repository, used to update the snapshot. , specRemoteRepoURL :: String - -- | Number of threads to use when building. + -- | Inject this number of threads into the config-override.mk file , specBuildThreads :: Int + -- | Inject this build flavour into the config-override.mk file + , specBuildFlavour :: String + -- | Cleanup after build , specCleanup :: Bool @@ -45,7 +48,6 @@ -- | If we're doing a continuous build, also build once on startup , specNow :: Bool - -- | Mailer to use to send build results, -- or Nothing if to not send mail. , specMailer :: Maybe Mailer @@ -56,7 +58,6 @@ -- | Send mail to this address. , specMailTo :: Maybe String - -- | User and host name to copy logs to eg 'overlord@deluge.ouroborus.net' , specLogUserHost :: Maybe String @@ -128,6 +129,7 @@ let urlSnapshot = specRemoteSnapshotURL spec let urlRepo = specRemoteRepoURL spec let buildThreads = specBuildThreads spec + let buildFlavour = specBuildFlavour spec ensureDir buildDir inDir buildDir @@ -140,9 +142,9 @@ io $ writeFile "log/01-wget.stdout" getOut io $ writeFile "log/01-wget.stderr" getErr - needs (takeFileName urlSnapshot) + needs (Remote.takeFileName urlSnapshot) outLn "* Unpacking snapshot" - ssystem $ "tar zxf " ++ takeFileName urlSnapshot + ssystem $ "tar zxf " ++ Remote.takeFileName urlSnapshot inDir "ddc-head" $ do @@ -154,7 +156,9 @@ outLn "* Writing build config" needs "make" io $ writeFile "make/config-override.mk" - $ unlines ["THREADS = " ++ show buildThreads] + $ unlines [ "THREADS = " ++ show buildThreads + , "BUILDFLAVOUR = " ++ buildFlavour + , "" ] outLn "* Building project" needs "Makefile" diff --git a/DDC/War/Task/Test.hs b/DDC/War/Task/Test.hs --- a/DDC/War/Task/Test.hs +++ b/DDC/War/Task/Test.hs @@ -83,7 +83,7 @@ -- Canonicalize all the paths and put them in a set (which sorts them) testFilesSet <- io $ liftM (Set.fromList . Seq.toList) - $ Seq.mapM canonicalizePath + $ Seq.mapM (canonicalizePath) $ testFilesRaw -- Skip over files with 'skip' in the path, @@ -168,10 +168,12 @@ -- on the console. (chanResult :: TChan Driver.Result) <- atomically $ newTChan + + tmp <- getTemporaryDirectory -- Fork a gang to run all the job chains. gang <- Driver.forkChainsIO - (specThreads spec) "/tmp" + (specThreads spec) tmp (Just chanResult) chains -- Fork the controller to display results and manage user input. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyrite (K) 2007-2012 The Disciplined Disciple Compiler Strike Force +Copyrite (K) 2007-2014 The Disciplined Disciple Compiler Strike Force All rights reversed. Permission is hereby granted, free of charge, to any person obtaining a copy @@ -13,18 +13,4 @@ The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - -------------------------------------------------------------------------------- -Under Australian law copyright is free and automatic. -By contributing to DDC authors grant all rights they have regarding their -contributions to the other members of the Disciplined Disciple Compiler Strike -Force, past, present and future, as well as placing their contributions under -the above license. - -Use "darcs show authors" to get a list of Strike Force members. - -------------------------------------------------------------------------------- -Redistributions of libraries in ./external are governed by their own licenses: - - - TinyPTC GNU Lesser General Public License - diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -4,6 +4,7 @@ import BuildBox.Pretty import BuildBox import System.Environment +import System.Directory import qualified DDC.War.Task.Nightly as N import qualified DDC.War.Task.Test as T @@ -26,9 +27,8 @@ -- | Run tests from the provided directories mainTest :: T.Spec -> IO () mainTest spec - = let - in do - result <- runBuild "/tmp" $ T.build spec + = do tmp <- getTemporaryDirectory + result <- runBuild tmp $ T.build spec case result of Left err -> error $ render $ ppr err Right _ -> return () @@ -37,7 +37,8 @@ -- | Run the nightly build. mainNightly :: N.Spec -> IO () mainNightly spec - = do result <- runBuild "/tmp" $ N.build spec + = do tmp <- getTemporaryDirectory + result <- runBuild tmp $ N.build spec case result of Left err -> error $ render $ ppr err Right result' -> putStrLn $ render $ ppr result' diff --git a/ddc-war.cabal b/ddc-war.cabal --- a/ddc-war.cabal +++ b/ddc-war.cabal @@ -1,5 +1,5 @@ Name: ddc-war -Version: 0.2.1.1 +Version: 0.4.1.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -15,21 +15,22 @@ Executable ddc-war Build-depends: - base == 4.5.*, - containers == 0.4.*, - stm == 2.2.*, - directory == 1.1.*, - buildbox == 2.1.*, + base >= 4.6 && < 4.8, + containers == 0.5.*, + directory == 1.2.*, random == 1.0.*, - process == 1.1.*, - filepath == 1.3.* - + buildbox == 2.1.*, + process == 1.2.*, + filepath == 1.3.*, + stm == 2.4.* + Main-is: Main.hs Other-modules: - DDC.War.Create.CreateDCE + DDC.War.Create.CreateDC DDC.War.Create.CreateDCX + DDC.War.Create.CreateDSX DDC.War.Create.CreateMainDS DDC.War.Create.CreateMainHS DDC.War.Create.CreateMainSH @@ -40,11 +41,12 @@ DDC.War.Driver.Gang DDC.War.Interface.Controller DDC.War.Interface.VT100 - DDC.War.Job.CompileDCE + DDC.War.Job.CompileDC DDC.War.Job.CompileDS DDC.War.Job.CompileHS DDC.War.Job.Diff DDC.War.Job.RunDCX + DDC.War.Job.RunDSX DDC.War.Job.RunExe DDC.War.Job.Shell DDC.War.Task.Nightly @@ -63,6 +65,7 @@ ScopedTypeVariables ghc-options: - -Wall -O2 + -Wall -fno-warn-unused-do-bind + -fno-warn-missing-methods -threaded