Revision 72bb6b4e htools/test.hs

b/htools/test.hs
25 25 

  		





  26
  26
  
    
module Main(main) where


  		





  27
  27
  
    

  		





  
  28
  
    
import Data.Char


  		





  28
  29
  
    
import Data.IORef


  		





  
  30
  
    
import Data.List


  		





  29
  31
  
    
import Test.QuickCheck


  		





  30
  32
  
    
import System.Console.GetOpt ()


  		





  31
  33
  
    
import System.IO


  		





  ......




  120
  122
  
    
  , (slow, testCluster)


  		





  121
  123
  
    
  ]


  		





  122
  124
  
    

  		





  
  125
  
    
-- | Extracts the name of a test group.


  		





  
  126
  
    
extractName :: (Args, (String, [(Args -> IO Result, String)])) -> String


  		





  
  127
  
    
extractName (_, (name, _)) = name


  		





  
  128
  
    

  		





  
  129
  
    
-- | Lowercase a string.


  		





  
  130
  
    
lower :: String -> String


  		





  
  131
  
    
lower = map toLower


  		





  
  132
  
    

  		





  123
  133
  
    
transformTestOpts :: Args -> Options -> IO Args


  		





  124
  134
  
    
transformTestOpts args opts = do


  		





  125
  135
  
    
  r <- case optReplay opts of


  		





  ......




  139
  149
  
    
  let wrap = map (wrapTest errs)


  		





  140
  150
  
    
  cmd_args <- System.getArgs


  		





  141
  151
  
    
  (opts, args) <- parseOpts cmd_args "test" options


  		





  142
  
  
    
  let tests = if null args


  		





  143
  
  
    
              then allTests


  		





  144
  
  
    
              else filter (\(_, (name, _)) -> name `elem` args) allTests


  		





  145
  
  
    
      max_count = maximum $ map (\(_, (_, t)) -> length t) tests


  		





  
  152
  
    
  tests <- (if null args


  		





  
  153
  
    
           then return allTests


  		





  
  154
  
    
           else (let args' = map lower args


  		





  
  155
  
    
                     selected = filter ((`elem` args') . lower . extractName)


  		





  
  156
  
    
                                allTests


  		





  
  157
  
    
                 in if null selected


  		





  
  158
  
    
                    then do


  		





  
  159
  
    
                      hPutStrLn stderr $ "No tests matching '"


  		





  
  160
  
    
                         ++ intercalate " " args ++ "', available tests: "


  		





  
  161
  
    
                         ++ intercalate ", " (map extractName allTests)


  		





  
  162
  
    
                      exitWith $ ExitFailure 1


  		





  
  163
  
    
                    else return selected))


  		





  
  164
  
    

  		





  
  165
  
    
  let max_count = maximum $ map (\(_, (_, t)) -> length t) tests


  		





  146
  166
  
    
  mapM_ (\(targs, (name, tl)) ->


  		





  147
  167
  
    
             transformTestOpts targs opts >>= \newargs ->


  		





  148
  168
  
    
             runTests name newargs (wrap tl) max_count) tests


  		












Also available in:
  Unified diff