first commit

tester/Grade.hs

@@ -0,0 +1,125 @@
+module Grade where
+
+import RunCommand
+import KompTest
+
+import Data.List
+import Data.Maybe
+import System.Directory
+import System.Environment
+import System.Exit
+import System.IO
+import System.Process
+import System.FilePath
+import System.Posix.Files
+import Control.Exception
+import Control.Monad
+import System.Console.GetOpt
+
+cmd c = do
+  putStrLn c
+  (out,err,code) <- runCommandStrWait c ""
+  putStrLn out
+  putStrLn err
+
+
+makeAbsolute p = do
+  c <- getCurrentDirectory
+  return (c </> p)
+
+maybeBuild _ [] = return ()
+maybeBuild groupPath0 ((tarOpt,subm) : _) = do
+   cmd $ "tar -C "++groupPath0 ++" -"++ tarOpt++"xvf "++ show (groupPath0 </> subm)
+   cmd $ "make -C " ++ show (groupPath0 </> "src")
+   
+testAll compiler bs exts [testSuitePath00, groupPath0] = do
+  allFiles <- getDirectoryContents groupPath0
+  let submissions = [(opts, s) | 
+                    (opts, suff) <- [("z", ".tar.gz"), ("j", ".tar.bz2"), ("j", ".tar.bzip2"), ("", ".tar")],
+                    s <- filter (suff `isSuffixOf`) allFiles]
+  maybeBuild groupPath0 submissions
+  let testSuitePath0 = groupPath0 </> "graderTestSuite"
+  cmd $ "rm -r " ++ testSuitePath0
+  cmd $ "cp -R " ++ testSuitePath00 </> "testsuite" ++ " " ++ testSuitePath0
+  let exePath0 = groupPath0 </> compiler
+
+  exePath <- makeAbsolute exePath0
+  groupPath <- makeAbsolute groupPath0
+ 
+  testSuitePath <- makeAbsolute testSuitePath0
+  curDir <- getCurrentDirectory
+  let exeDir = takeDirectory exePath
+  putStrLn $ "Running tests for " ++ exePath
+
+  let libpath = groupPath </> "lib"
+  let testProg = if null bs then Nothing
+                 else case bs of
+                   "JVM"  : _ -> Just testJVM
+                   "LLVM" : _ -> Just testLLVM
+                   "x86" : _ -> Just testx86
+                   b : _ -> error ("Unknown backend: " ++ b) 
+  setCurrentDirectory exeDir
+  summary <- forM (testSpecs testProg exts libpath) $ \(points, name, tests) -> do
+    putStrLn $ name ++ "..."
+    results <- forM tests $ \(good, p, testFunction) -> do
+        testFiles <- getTestFilesForPath (testSuitePath </> p)
+        putStrLn $ p ++ "..."
+        rs <- testFunction exePath good testFiles
+        report p rs 
+        return (p, rs)
+    putStrLn $ "Passed suites: " ++ (concat $ intersperse ", " $ [p | (p,rs) <- results, and rs])
+    let tally = concat (map snd results)
+    return (name, if and tally then points else (0 :: Int), tally)
+
+  setCurrentDirectory curDir
+
+  putStrLn $ "Summary:\n" ++ unlines (map summaryLine summary)
+  putStrLn $ "Credits total: " ++ show (sum [x | (_,x,_) <- summary])
+
+padl n s = replicate (n - length s) ' ' ++ s
+
+
+summaryLine (name, points, tests) = 
+  padl 2 (show points) ++ " " ++ name ++ " " ++ "(" ++ show (length (filter id tests)) ++ "/" ++ show (length tests) ++ ")"
+
+testSpecs testProg exts libpath = 
+  (0, "Compiling core programs",     [(True, "good",testCompilation), (False, "bad", testCompilation)]) : 
+  map (\x -> (0,"Compiling extension " ++ x,[(True,"extensions/"++x,testCompilation)])) exts ++ 
+  case testProg of   
+     Nothing -> []
+     Just backEnd ->
+      (0, "Running core programs",        [(True, "good",backEnd libpath)]) : 
+      map (\x -> (6,"Running extension " ++ x,[(True,"extensions/"++x,backEnd libpath)])) exts 
+
+
+
+testBack back cmd good fs = if good then test cmd fs back else return []
+
+testJVM classpath = testBack (jvmBackend classpath)
+testLLVM libpath  = testBack (llvmBackend libpath)
+testx86 libpath   = testBack (x86Backend libpath)
+
+data Flag = SearchScript String
+          | Extension String
+          | Back String
+   deriving (Eq,Ord)
+
+flags =
+    [Option "s" ["search-compiler"] (ReqArg SearchScript "<compiler>") "search for the specified compiler",
+     Option "x" ["extension"] (ReqArg Extension "<extension>") "specify extensions to test",
+     Option "b" ["backend"] (ReqArg Back "<backend>") "specify backend"]
+
+main = do
+  argv <- getArgs
+  case getOpt Permute flags argv of
+    (opts,args,[]) -> do
+         let searchList0 = [s | SearchScript s <- opts]
+             compiler = if null searchList0 then "jlc" else head searchList0
+             exts = [e | Extension e <- opts]
+             bs = [b | Back b <- opts]
+         testAll compiler bs exts args
+    (_,_,errs) -> do
+            hPutStrLn stderr (concat errs ++ usageInfo "" flags)
+            exitWith (ExitFailure 1)
+
+ where defaultSearchList = []