hstest-0.0.1: hstest.hs
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 <koen@chalmers.se>, 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)