diff --git a/f/test-names.hs b/f/test-names.hs new file mode 100644 --- /dev/null +++ b/f/test-names.hs @@ -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) + + diff --git a/hstest.cabal b/hstest.cabal --- a/hstest.cabal +++ b/hstest.cabal @@ -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 -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 +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, diff --git a/hstest.hs b/hstest.hs --- a/hstest.hs +++ b/hstest.hs @@ -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 , 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)