import Control.Monad (when) import Data.Char (toUpper) import Data.Dynamic (fromDynamic) import Data.List (intercalate, isPrefixOf, isSuffixOf) 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, importPaths, GhcMode (CompManager), LoadHowMuch (LoadAllTargets), SuccessFlag (Failed, Succeeded), TyThing (AnId), GhcLink (LinkInMemory), TargetId (TargetFile), Target (Target, targetId), HscTarget (HscInterpreted), 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, 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 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) {- This is how to embed QuickCheck properties in your code: make them top-level declarations whose names start with `prop_`. You don't need to include each property explicitly in a list; that would make it too easy to add a property but forget to run it. Instead, `hstest` looks through your program and builds the list of properties to run itself. -} prop_Count_Monoid_leftIdentity, prop_Count_Monoid_rightIdentity :: Count -> Bool prop_Count_Monoid_associative :: Count -> Count -> Count -> Bool prop_Count_Monoid_leftIdentity x = mappend mempty x == x prop_Count_Monoid_rightIdentity x = mappend x mempty == x prop_Count_Monoid_associative x y z = mappend x (mappend y z) == mappend (mappend x y) z data QCResult = QCFailed [String] | QCPassed | QCExhausted Int | QCUnparsed String 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] 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 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 reportCount s' (Count cs) = concat [s', ": ", if null s then "0 tests!" else s] where s = ucfirst $ intercalate ", " . catMaybes . zipWith f ss $ cs f _ 0 = Nothing f (s, (s', _)) 1 = Just $ concat [s, " 1 ", s'] f (s, (_, s')) c = Just $ concat [s, " ", show c, " ", s'] 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", 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 : 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 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 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", "| cPassed == 100 = \"Passed\"", "| cMissed == 1000 = \"Exhausted\"", "| otherwise = let (rnd1, rnd2) = System.Random.split rnd0 in ", "let result = Test.QuickCheck.generate ((cPassed `div` 2) + 3) rnd2 gen in ", "case Test.QuickCheck.ok result of", "{Nothing -> f rnd1 cPassed (1 + cMissed) stamps;", "Just True -> f rnd1 (1 + cPassed) cMissed ", "(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 -> 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"]] 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.importPaths = G.importPaths dynFlags ++ reverse (ndsImportFromFlags flags)} G.setTargets targets G.load G.LoadAllTargets >>= loaded 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 [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 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"] 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 "i" [] (OptArg (withNdsImport' . splitSearchPath . fromMaybe "") "[DIRLIST]") "add directory to module search list (leave blank to clear)"] usageMsg = usageInfo "Usage: hstest [FLAGS] [SOURCE FILES]" cmdLineDescr getCommandLineOptions wrap = getArgs >>= act . getOpt (ReturnInOrder wrap) cmdLineDescr where act (opts, _, []) = return opts act (_, _, errs) = hPutStrLn stderr (unlines errs ++ usageMsg) >> exitFailure data Options = Options {modeFromOptions :: Mode, nfsFromOptions :: [String], flagsFromOptions :: Flags} 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], ndsImportFromFlags :: [FilePath]} data PkgFlag = ExposePkg String | HidePkg String | IgnorePkg String 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 {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)