Ticket #181: dissect.2.hs

File dissect.2.hs, 2.8 KB (added by wferi, 11 years ago)
Line 
1module Main where
2import Data.Maybe
3import Text.Regex
4import System.IO
5import System.Directory
6import Control.Monad
7
8versionFile :: FilePath
9versionFile = "version.txt"
10
11deletePrefix :: String -> String -> Maybe String
12deletePrefix _ [] = Just []
13deletePrefix [] s = Just s
14deletePrefix (p:ps) (s:ss) | p == s    = deletePrefix ps ss
15                           | otherwise = Nothing
16
17runBuild :: IO ()
18runBuild = getLine >>= putStrLn . fromMaybe (error "No header\n") .
19           deletePrefix "Tests from build "
20
21getNonBlank :: IO String
22getNonBlank = do line <- getLine
23                 if line == "" then getNonBlank else return line
24
25runNewVersion :: IO ()
26runNewVersion = do h <- openFile versionFile WriteMode
27                   short <- accRead h ""
28                   hClose h
29                   putStrLn $ init short
30    where accRead h s =
31              do line <- getLine
32                 case matchRegex (mkRegex "^([a-zA-Z0-9]+)=\"(.+)\"$") line of
33                   Just [id,val] -> hPutStrLn h (id ++ " " ++ val) >>
34                                    accRead h (s++val++".")
35                   Nothing       -> return s
36
37runResults :: String -> String -> IO String
38runResults unit test =
39    do h <- openFile tmpFile WriteMode
40       res <- copy h
41       size <- hTell h
42       hClose h
43       when (size > 0) $ renameFile tmpFile (unit++"_"++test++".txt")
44       return $ if null res then "failed" else unwords res
45    where tmpFile = "dissect.tmp"
46          copy h  = do l <- getLine
47                       case matchRegexAll (mkRegex $ unit++":"++test++" done") l of
48                         Just (b,_,_,_) -> hPutStr h b >>
49                                           return []
50                         Nothing -> hPutStrLn h l >> case matchRegex (mkRegex $ '^':test++": ([0-9]+) tests executed, ([0-9]+) marked as todo, ([0-9]+) failures.$") l of
51                                                       Just res -> getLine >> return res
52                                                       Nothing  -> copy h
53
54runTestBlock :: IO ()
55runTestBlock =
56    do header <- getNonBlank
57       case matchRegex (mkRegex "^([^:]+):([^ ]+) ([^ ]+) ?(absent)?$")
58                       header of
59         Nothing -> error $ "Expecting test header, got "++header
60         Just (test@[_,_,_,"absent"]) -> putStrLn $ unwords test
61         Just [unit,test,dir,""] -> do results <- runResults unit test
62                                       putStrLn $ unwords
63                                         [unit,test,dir,results]
64       eof <- isEOF
65       if eof then return () else runTestBlock
66
67main :: IO ()
68main = do runBuild
69          versionStr <- getNonBlank
70          if versionStr == "Operating system version:"
71             then runNewVersion
72             else do writeFile versionFile (versionStr++"\n")
73                     putStrLn versionStr
74          runTestBlock