hstest 0.0.0 → 0.0.1
raw patch · 3 files changed
+176/−80 lines, 3 filesdep +HUnitdep +filepathdep ~basedep ~ghc
Dependencies added: HUnit, filepath
Dependency ranges changed: base, ghc
Files
- f/test-names.hs +15/−0
- hstest.cabal +26/−20
- hstest.hs +135/−60
+ f/test-names.hs view
@@ -0,0 +1,15 @@+prop_withNoArgs = True+prop_withOneArg _ = True+prop_withTwoArgs _ _ = True++test_withNoArgs = (return True) :: IO Bool+test_withOneArg _ = (return False) :: IO Bool -- this is of the wrong type => it needs picking up so we can give an error message++decoy_symbol = prop_notTopLevel+ where prop_notTopLevel = False -- these two are not picked up -- maybe they should provoke an error instead?+decoy = test_notTopLevel+ where test_notTopLevel = (return False) :: IO Bool++(prop_first, test_second) = (True, return True) :: (Bool, IO Bool)++
hstest.cabal view
@@ -1,21 +1,23 @@-Name: hstest-Version: 0.0.0-Cabal-Version: >= 1.2-Build-Type: Custom-License: BSD3-License-File: LICENSE-Copyright: © Dave Hinton, 2010; portions © Koen Claessen-Author: Dave Hinton-Maintainer: Dave Hinton <beakerchu@googlemail.com>-Stability: alpha-Homepage: http://bitbucket.org/dave4420/hstest/wiki/Home-Tested-With: GHC == 6.10.1-Category: Testing-Synopsis: Tests properties in specified modules via QuickCheck; uses GHC api for speed+Name: hstest+Version: 0.0.1+Cabal-Version: >= 1.8+Build-Type: Custom+License: BSD3+License-File: LICENSE+Copyright: © Dave Hinton, 2010; portions © Koen Claessen+Author: Dave Hinton+Maintainer: Dave Hinton <beakerchu@googlemail.com>+Stability: alpha+Homepage: http://bitbucket.org/dave4420/hstest/wiki/Home+Bug-Reports: http://bitbucket.org/dave4420/hstest/issues?status=new&status=open+Extra-Source-Files: f/*.hs+Tested-With: GHC == 6.10.1, GHC == 6.12.1+Category: Testing+Synopsis: Runs tests via QuickCheck1 and HUnit; like quickCheck-script but uses GHC api Description: .- 'hstest' looks through all Haskell source files in the current directory (by default), finds all properties to test (properties- must have a name that starts 'prop_'), and runs them via QuickCheck.+ 'hstest' looks through all Haskell source files in the current directory (by default), runs all properties via QuickCheck 1+ (properties must have a name that starts 'prop_'), and runs all tests via HUnit (tests must have a name that starts 'test_'). . For example, suppose you have this Haskell source file called 'mysort.hs': .@@ -24,8 +26,8 @@ > prop_lengthStaysTheSame xs = length xs == length (mySort xs) > prop_sumStaysTheSame xs = sum xs == sum (mySort xs) > prop_lowestElementAtStart, prop_highestElementAtEnd :: [Int] -> Bool- > prop_lowestElementAtStart xs = not (null xs) ==> minimum xs = head (mySort xs)- > prop_highestElementAtEnd xs = not (null xs) ==> maximum xs = last (mySort xs)+ > prop_lowestElementAtStart xs = not (null xs) ==> minimum xs == head (mySort xs)+ > prop_highestElementAtEnd xs = not (null xs) ==> maximum xs == last (mySort xs) . Then to check all these tests, you run .@@ -41,14 +43,18 @@ Executable hstest Main-Is: hstest.hs- Build-Depends: base >= 4.0.0 && < 4.2,+ Build-Depends: base >= 4.0.0 && < 4.3, -- tested with 4.0.0.0 and 4.1.0.0 directory >= 1.0.0 && < 1.1, -- tested with 1.0.0.2 and 1.0.0.3- ghc >= 6.10.1 && < 6.12,+ filepath >= 1.1.0 && < 1.2,+ -- tested with 1.1.0.2+ ghc >= 6.10.1 && < 6.12 || >= 6.12.1 && < 6.14, -- tested with 6.10.1 and 6.10.3 ghc-paths >= 0.1.0 && < 0.2, -- tested with 0.1.0.5+ HUnit >= 1.2.0 && < 1.3,+ -- tested with 1.2.0.3 mtl >= 1.1.0 && < 1.2, -- tested with 1.1.0.2 QuickCheck >= 1.2.0.0 && < 1.3,
hstest.hs view
@@ -2,29 +2,34 @@ import Data.Char (toUpper) import Data.Dynamic (fromDynamic) import Data.List (intercalate, isPrefixOf, isSuffixOf)-import Data.Maybe (catMaybes)-import Data.Monoid (Monoid (mappend, mempty, mconcat))+import Data.Maybe (catMaybes, fromMaybe)+import Data.Monoid (Monoid (mappend, mempty, mconcat), Endo (Endo, appEndo))+import Data.Version (showVersion) import qualified DynFlags as G (defaultDynFlags, PackageFlag (ExposePackage, HidePackage, IgnorePackage)) import qualified GHC as G (GhcMonad, packageFlags, getModuleGraph, ms_mod, setContext, moduleName, moduleNameString, targetAllowObjCode, targetContents, ghcLink, flags, hscTarget, load, modInfoTyThings, getModuleInfo, setTargets, dynCompileExpr, runGhc, defaultErrorHandler, getSessionDynFlags,- setSessionDynFlags, ghcMode, GhcMode (CompManager),+ setSessionDynFlags, ghcMode, importPaths, GhcMode (CompManager), LoadHowMuch (LoadAllTargets), SuccessFlag (Failed, Succeeded), TyThing (AnId), GhcLink (LinkInMemory), TargetId (TargetFile), Target (Target, targetId), HscTarget (HscInterpreted),- DynFlag (Opt_ImplicitImportQualified))+ DynFlag (Opt_ImplicitImportQualified), Ghc, ms_location, ml_hs_file) import qualified GHC.Paths as G (libdir) import qualified MonadUtils as G (liftIO) import qualified Name as G (nameOccName) import qualified OccName as G (occNameString)+import Paths_hstest (version) import System.Console.GetOpt (usageInfo, getOpt, OptDescr (Option), ArgOrder (ReturnInOrder),- ArgDescr (ReqArg, NoArg))+ ArgDescr (ReqArg, NoArg, OptArg)) import System.Directory (getDirectoryContents) import System.Environment (getArgs) import System.Exit (exitWith, exitFailure, exitSuccess, ExitCode (ExitSuccess, ExitFailure))+import System.FilePath (splitSearchPath) import System.IO (hPutStrLn, stderr)-import Test.QuickCheck (Arbitrary (arbitrary, coarbitrary), variant, vector)+import qualified Test.HUnit as HU (Counts (Counts, errors, failures, tried),+ assertEqual)+import qualified Test.QuickCheck as QC (Arbitrary (arbitrary, coarbitrary), variant, vector) import qualified Var as G (varName) @@ -45,30 +50,44 @@ prop_Count_Monoid_associative x y z = mappend x (mappend y z) == mappend (mappend x y) z -data TestResult = Failed [String]- | Passed- | Exhausted Int- | Unparsed String+data QCResult = QCFailed [String]+ | QCPassed+ | QCExhausted Int+ | QCUnparsed String -reportResult n (Unparsed s) = concat ["While testing ", n, ":\n", s]-reportResult n (Exhausted c) = concat ["Exhausted ", n, " after ", show c, " tests\n"]-reportResult n Passed = concat ["Passed ", n, "\n"]-reportResult n (Failed params) = unlines (concat ["Failed ", n, ":"] : map f params)+reportQCResult n (QCUnparsed s) = concat ["While testing ", n, ":\n", s]+reportQCResult n (QCExhausted c) = concat ["Exhausted ", n, " after ", show c, " tests\n"]+reportQCResult n QCPassed = concat ["Passed ", n, "\n"]+reportQCResult n (QCFailed params) = unlines (concat ["Failed ", n, ":"] : map f params) where f param = concat [" * ", param] -shouldExplicitlyReportResult Passed = False-shouldExplicitlyReportResult _ = True+shouldExplicitlyReportQCResult QCPassed = False+shouldExplicitlyReportQCResult _ = True +data HUResult = HUResult HU.Counts [HUProblem]+data HUProblem = HUError String | HUFailure String++reportHUResult n (HUResult _ []) = concat ["Passed ", n, "\n"]+reportHUResult n (HUResult _ problems) = concatMap f problems+ where f (HUFailure "") = concat ["Failed ", n, "\n"]+ f (HUFailure s) = concat ["Failed ", n, ": ", s, "\n"]+ f (HUError "") = concat ["Error in ", n, "\n"]+ f (HUError s) = concat ["Error in ", n, ": ", s, "\n"]++shouldExplicitlyReportHUResult (HUResult _ []) = False+shouldExplicitlyReportHUResult (HUResult _ _) = True++ data Count = Count [Int] deriving (Eq, Show) instance Monoid Count where mempty = Count (replicate cResultIndicies 0) mappend (Count xs) (Count ys) = Count (zipWith (+) xs ys) -instance Arbitrary Count- where arbitrary = fmap Count $ vector cResultIndicies- coarbitrary (Count xs) z = foldr variant z xs+instance QC.Arbitrary Count+ where arbitrary = fmap Count $ QC.vector cResultIndicies+ coarbitrary (Count xs) z = foldr QC.variant z xs countResultI i = Count $ map f [0 .. cResultIndicies - 1] where f i' = if i == i' then 1 else 0@@ -81,35 +100,50 @@ ss = [("failed", sProperties), ("couldn't parse results of", sProperties), ("couldn't compile", sFiles),+ ("failed", sTests),+ ("found errors in", sTests), ("exhausted arguments while checking", sProperties),- ("passed", sProperties)]+ ("passed", sProperties),+ ("passed", sTests)] sFiles = ("file", "files") sProperties = ("property", "properties")+ sTests = ("test", "tests") ucfirst "" = "" ucfirst (ch : s) = toUpper ch : s putCountLn s c = putStrLn (reportCount s c) >> return c -iFailedProperty : iUnparsedProperty : iUncompiledFile : -- FAIL- iExhaustedProperty : -- not proven- iPassedProperty : -- WIN- cResultIndicies : _ = [0..] -- must be grouped like this for `exitCodeFor` to work+iFailedProperty : iUnparsedProperty : iUncompiledFile : iFailedTest : iErroneousTest : -- FAIL+ iExhaustedProperty : -- not proven+ iPassedProperty : iPassedTest : -- WIN+ cResultIndicies : _ = [0..] -- must be grouped like this for `exitCodeFor` to work exitCodeFor (Count cs) = case length $ takeWhile (== 0) cs of c | c < iExhaustedProperty -> ExitFailure 2 c | c < iPassedProperty -> ExitFailure 1 _ -> ExitSuccess -countResult (Failed _) = countResultI iFailedProperty-countResult Passed = countResultI iPassedProperty-countResult (Exhausted _) = countResultI iExhaustedProperty-countResult (Unparsed _) = countResultI iUnparsedProperty+countQCResult (QCFailed _) = countResultI iFailedProperty+countQCResult QCPassed = countResultI iPassedProperty+countQCResult (QCExhausted _) = countResultI iExhaustedProperty+countQCResult (QCUnparsed _) = countResultI iUnparsedProperty +countHUResult (HUResult count _) = mconcat [mreplicate cPassed (countResultI iPassedTest),+ mreplicate cErroneous (countResultI iErroneousTest),+ mreplicate cFailed (countResultI iFailedTest)]+ where mreplicate c x = mconcat $ replicate c x+ cErroneous = HU.errors count+ cFailed = HU.failures count+ cPassed = HU.tried count - cFailed - cErroneous -runTest :: G.GhcMonad m => String -> m Count-runTest nTest = do result <- fmap (maybe wrongTestResult divineTestResult . fromDynamic) (G.dynCompileExpr expr)- when (shouldExplicitlyReportResult result) (G.liftIO $ putStr $ reportResult nTest result)- return (countResult result)++data IndividualTest = QuickCheckTest String | HUnitTest String deriving (Eq, Show)++runIndividualTest :: G.GhcMonad m => IndividualTest -> m Count+runIndividualTest (QuickCheckTest nTest)+ = do result <- fmap (maybe wrongTestResult divineTestResult . fromDynamic) (G.dynCompileExpr expr)+ when (shouldExplicitlyReportQCResult result) (G.liftIO $ putStr $ reportQCResult nTest result)+ return (countQCResult result) where -- `expr` originally copied from Test.QuickCheck, copyright © Koen Claessen <koen@chalmers.se>, licenced under BSD3 expr = concat ["let gen = Test.QuickCheck.evaluate (Test.QuickCheck.property ", nTest, ") in ", "let f rnd0 cPassed cMissed stamps",@@ -123,46 +157,78 @@ "(Test.QuickCheck.stamp result : stamps);", "Just False -> unlines (\"Failed\" : Test.QuickCheck.arguments result)} in ", "f (System.IO.Unsafe.unsafePerformIO System.Random.newStdGen) 0 0 []"]- divineTestResult :: String -> TestResult- divineTestResult "Passed" = Passed- divineTestResult "Exhausted" = Exhausted 1000- divineTestResult s | "Failed" `isPrefixOf` s = Failed (tail $ lines s)- | otherwise = Unparsed s- wrongTestResult = Failed ["Was expecting property to be of type Testable a => a"]+ divineTestResult :: String -> QCResult+ divineTestResult "Passed" = QCPassed+ divineTestResult "Exhausted" = QCExhausted 1000+ divineTestResult s | "Failed" `isPrefixOf` s = QCFailed (tail $ lines s)+ | otherwise = QCUnparsed s+ wrongTestResult = QCFailed [concat ["Was expecting ", nTest, " to be of type Test.QuickCheck.Testable a => a"]] -runTests :: Flags -> String -> IO Count-runTests flags nf = G.runGhc (Just G.libdir) (G.defaultErrorHandler G.defaultDynFlags init) >>= putCountLn nf+runIndividualTest (HUnitTest nTest)+ = do result <- fmap (maybe wrongTestResult divineTestResult . fromDynamic) (G.dynCompileExpr expr)+ when (shouldExplicitlyReportHUResult result) (G.liftIO $ putStr $ reportHUResult nTest result)+ return (countHUResult result)+ where expr = concat ["let onStart huState myState = return myState in ",+ "let onError message huState myState = return (Left message : myState) in ",+ "let onFailure message huState myState = return (Right message : myState) in ",+ "let f (Test.HUnit.Counts a b c d, messages) = (a, b, c, d, messages) in ",+ "f (System.IO.Unsafe.unsafePerformIO (Test.HUnit.performTest onStart onError onFailure []",+ "(Test.HUnit.test ", nTest, ")))"]+ divineTestResult :: (Int, Int, Int, Int, [Either String String]) -> HUResult+ divineTestResult (a, b, c, d, messages) = HUResult (HU.Counts a b c d) $ map f (reverse messages)+ where f (Left s) = HUError s+ f (Right s) = HUFailure s+ wrongTestResult = HUResult (HU.Counts 1 1 1 0)+ [HUError (concat ["Was expecting ", nTest, " to be of type Test.HUnit.Testable a => a"])]++runModuleTests' :: Monoid res => (IndividualTest -> G.Ghc res) -> res -> Flags -> String -> IO res+runModuleTests' runTest wontCompile flags nf = G.runGhc (Just G.libdir) (G.defaultErrorHandler G.defaultDynFlags init) where init = do -- have to get and then set dynamic flags even if I don't want to change them -- somehow this initialises fields I don't want to care about dynFlags <- G.getSessionDynFlags G.setSessionDynFlags dynFlags {G.ghcMode = G.CompManager, G.ghcLink = G.LinkInMemory, G.hscTarget = G.HscInterpreted, G.flags = G.Opt_ImplicitImportQualified : G.flags dynFlags,- G.packageFlags = packageFlags ++ G.packageFlags dynFlags}+ G.packageFlags = packageFlags ++ G.packageFlags dynFlags,+ G.importPaths = G.importPaths dynFlags ++ reverse (ndsImportFromFlags flags)} G.setTargets targets G.load G.LoadAllTargets >>= loaded- loaded G.Failed = return (countResultI iUncompiledFile)- loaded G.Succeeded = G.getModuleGraph >>= loadedModule . map G.ms_mod- loadedModule [onlyModule]- = G.getModuleInfo onlyModule >>= performTests . fmap (catMaybes . map nTestFromTyThing . G.modInfoTyThings)+ loaded G.Failed = return wontCompile+ loaded G.Succeeded = G.getModuleGraph >>= loadedModule . f+ where f summaries = (summaries, map G.ms_mod $ filter ((== Just nf) . G.ml_hs_file . G.ms_location) summaries)+ loadedModule (_, [interestingModule])+ = G.getModuleInfo interestingModule >>= performTests . fmap (catMaybes . map testFromTyThing . G.modInfoTyThings) where performTests Nothing = error "Was expecting module to be loaded"- performTests (Just ns) = G.setContext [onlyModule] [] >> fmap mconcat (mapM runTest ns)- loadedModule mods = error (concat ["loadedModule was expecting only one module but got ", show (length mods), ": ",- intercalate ", " $ map (G.moduleNameString . G.moduleName) mods])- nTestFromTyThing (G.AnId identity) = if "prop_" `isPrefixOf` n then Just n else Nothing+ performTests (Just ns) = G.setContext [interestingModule] [] >> fmap mconcat (mapM runTest ns)+ loadedModule (summaries, _) = error (concat ["loadedModule did not find ", nf, " in ",+ intercalate ", " $ map display summaries])+ where display summary = concat [G.moduleNameString (G.moduleName $ G.ms_mod summary), " (",+ show (G.ml_hs_file $ G.ms_location summary), ")"]+ testFromTyThing (G.AnId identity) = if "prop_" `isPrefixOf` n then Just (QuickCheckTest n) else + if "test_" `isPrefixOf` n then Just (HUnitTest n) else Nothing where n = G.occNameString . G.nameOccName $ G.varName identity- nTestFromTyThing _ = Nothing+ testFromTyThing _ = Nothing targets = [G.Target {G.targetId = G.TargetFile nf Nothing, G.targetAllowObjCode = False, G.targetContents = Nothing}] packageFlags = map f (pkgsFromFlags flags) where f (ExposePkg n) = G.ExposePackage n f (HidePkg n) = G.HidePackage n f (IgnorePkg n) = G.IgnorePackage n +test_collectCorrectNamesOfTests = runModuleTests' (return . (: [])) [] defaultFlags "f/test-names.hs" >>= HU.assertEqual "" correct+ where correct = [QuickCheckTest "prop_withNoArgs", QuickCheckTest "prop_withOneArg", QuickCheckTest "prop_withTwoArgs",+ HUnitTest "test_withNoArgs", HUnitTest "test_withOneArg",+ QuickCheckTest "prop_first", HUnitTest "test_second"] -cmdLineDescr = [Option "" ["help"] (NoArg $ withHelpOption True) "display this help",+runModuleTests flags nf = runModuleTests' runIndividualTest (countResultI iUncompiledFile) flags nf >>= putCountLn nf+++cmdLineDescr = [Option "" ["help"] (NoArg $ withModeOption HelpMode) "display this help",+ Option "" ["version"] (NoArg $ withModeOption VersionMode) "show the version number", Option "" ["expose-package"] (ReqArg (withPkg . ExposePkg) "PACKAGE") "expose a package", Option "" ["hide-package"] (ReqArg (withPkg . HidePkg) "PACKAGE") "hide a package",- Option "" ["ignore-package"] (ReqArg (withPkg . IgnorePkg) "PACKAGE") "ignore a package"]+ Option "" ["ignore-package"] (ReqArg (withPkg . IgnorePkg) "PACKAGE") "ignore a package",+ Option "i" [] (OptArg (withNdsImport' . splitSearchPath . fromMaybe "") "[DIRLIST]")+ "add directory to module search list (leave blank to clear)"] usageMsg = usageInfo "Usage: hstest [FLAGS] [SOURCE FILES]" cmdLineDescr @@ -170,27 +236,36 @@ where act (opts, _, []) = return opts act (_, _, errs) = hPutStrLn stderr (unlines errs ++ usageMsg) >> exitFailure -data Options = Options {helpFlagFromOptions :: Bool,+data Options = Options {modeFromOptions :: Mode, nfsFromOptions :: [String], flagsFromOptions :: Flags}-noOptions = Options False [] defaultFlags-withHelpOption flag opts = opts {helpFlagFromOptions = flag}+data Mode = NormalMode | HelpMode | VersionMode+noOptions = Options NormalMode [] defaultFlags+withModeOption mode opts = opts {modeFromOptions = mode} withNfOption nf opts = opts {nfsFromOptions = nf : nfsFromOptions opts} withNfsOption nfs opts = opts {nfsFromOptions = nfs}+alterFlags :: (Flags -> Flags) -> Options -> Options alterFlags f opts = opts {flagsFromOptions = f (flagsFromOptions opts)} -data Flags = Flags {pkgsFromFlags :: [PkgFlag]}+data Flags = Flags {pkgsFromFlags :: [PkgFlag],+ ndsImportFromFlags :: [FilePath]} data PkgFlag = ExposePkg String | HidePkg String | IgnorePkg String-defaultFlags = Flags []+defaultFlags = Flags [] [] withPkg pkg = alterFlags $ \flags -> flags {pkgsFromFlags = pkg : pkgsFromFlags flags}+withNdImport nd = alterFlags $ \flags -> flags {ndsImportFromFlags = nd : ndsImportFromFlags flags}+withNdsImport nds = alterFlags $ \flags -> flags {ndsImportFromFlags = nds}+withNdsImport' [] = withNdsImport []+withNdsImport' nds = appEndo . mconcat . map (Endo . withNdImport) $ nds main = fmap (foldr ($) noOptions) (getCommandLineOptions withNfOption) >>= defaultNfs >>= act >>= exitWith . exitCodeFor- where act Options {helpFlagFromOptions = True} = putStrLn usageMsg >> exitSuccess- act opts @ Options {nfsFromOptions = [nf]} = runTests (flagsFromOptions opts) nf- act opts = mapM (runTests $ flagsFromOptions opts) (nfsFromOptions opts) >>= putCountLn "Total" . mconcat+ where act Options {modeFromOptions = VersionMode} = putStrLn ("hstest " ++ showVersion version) >> exitSuccess+ act Options {modeFromOptions = HelpMode} = putStrLn usageMsg >> exitSuccess+ act opts @ Options {nfsFromOptions = [nf]} = runTests opts nf+ act opts = mapM (runTests opts) (nfsFromOptions opts) >>= putCountLn "Total" . mconcat defaultNfs opts @ Options {nfsFromOptions = []} = fmap ((`withNfsOption` opts) . filter (".hs" `isSuffixOf`)) (getDirectoryContents ".") defaultNfs opts = return opts+ runTests opts = runModuleTests (flagsFromOptions opts)