hstest (empty) → 0.0.0
raw patch · 4 files changed
+286/−0 lines, 4 filesdep +QuickCheckdep +basedep +directorybuild-type:Customsetup-changed
Dependencies added: QuickCheck, base, directory, ghc, ghc-paths, mtl, random
Files
- LICENSE +26/−0
- Setup.lhs +6/−0
- hstest.cabal +58/−0
- hstest.hs +196/−0
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright © 2009, Dave Hinton+All rights reserved.++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.+ * Neither the name of the copyright holder nor the names of its contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple++> main = defaultMain+
+ hstest.cabal view
@@ -0,0 +1,58 @@+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+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.+ .+ For example, suppose you have this Haskell source file called 'mysort.hs':+ .+ > mySort xs = ... -- a function you wish to test (definition elided)+ >+ > 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)+ .+ Then to check all these tests, you run+ .+ > $ hstest+ > Failed prop_highestElementAtEnd:+ > * [-3,2,-2]+ > mysort.hs: Failed 1 property, passed 3 properties+ .+ Oops! Fix 'mySort' and try again:+ .+ > $ hstest+ > mysort.hs: Passed 4 properties++Executable hstest+ Main-Is: hstest.hs+ Build-Depends: base >= 4.0.0 && < 4.2,+ -- 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,+ -- tested with 6.10.1 and 6.10.3+ ghc-paths >= 0.1.0 && < 0.2,+ -- tested with 0.1.0.5+ mtl >= 1.1.0 && < 1.2,+ -- tested with 1.1.0.2+ QuickCheck >= 1.2.0.0 && < 1.3,+ -- tested with 1.2.0.0+ random >= 1.0.0 && < 1.1+ -- tested with 1.0.0.1+
+ hstest.hs view
@@ -0,0 +1,196 @@+import Control.Monad (when)+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 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),+ LoadHowMuch (LoadAllTargets), SuccessFlag (Failed, Succeeded),+ TyThing (AnId), GhcLink (LinkInMemory), TargetId (TargetFile),+ Target (Target, targetId), HscTarget (HscInterpreted),+ DynFlag (Opt_ImplicitImportQualified))+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 System.Console.GetOpt (usageInfo, getOpt, OptDescr (Option), ArgOrder (ReturnInOrder),+ ArgDescr (ReqArg, NoArg))+import System.Directory (getDirectoryContents)+import System.Environment (getArgs)+import System.Exit (exitWith, exitFailure, exitSuccess, ExitCode (ExitSuccess, ExitFailure))+import System.IO (hPutStrLn, stderr)+import Test.QuickCheck (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 TestResult = Failed [String]+ | Passed+ | Exhausted Int+ | Unparsed 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)+ where f param = concat [" * ", param]++shouldExplicitlyReportResult Passed = False+shouldExplicitlyReportResult _ = 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++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),+ ("exhausted arguments while checking", sProperties),+ ("passed", sProperties)]+ sFiles = ("file", "files")+ sProperties = ("property", "properties")+ 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++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+++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)+ 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 -> 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"]++runTests :: Flags -> String -> IO Count+runTests flags nf = G.runGhc (Just G.libdir) (G.defaultErrorHandler G.defaultDynFlags init) >>= putCountLn nf+ 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.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)+ 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+ where n = G.occNameString . G.nameOccName $ G.varName identity+ nTestFromTyThing _ = 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+++cmdLineDescr = [Option "" ["help"] (NoArg $ withHelpOption True) "display this help",+ 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"]++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 {helpFlagFromOptions :: Bool,+ nfsFromOptions :: [String],+ flagsFromOptions :: Flags}+noOptions = Options False [] defaultFlags+withHelpOption flag opts = opts {helpFlagFromOptions = flag}+withNfOption nf opts = opts {nfsFromOptions = nf : nfsFromOptions opts}+withNfsOption nfs opts = opts {nfsFromOptions = nfs}+alterFlags f opts = opts {flagsFromOptions = f (flagsFromOptions opts)}++data Flags = Flags {pkgsFromFlags :: [PkgFlag]}+data PkgFlag = ExposePkg String+ | HidePkg String+ | IgnorePkg String+defaultFlags = Flags []+withPkg pkg = alterFlags $ \flags -> flags {pkgsFromFlags = pkg : pkgsFromFlags flags}++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+ defaultNfs opts @ Options {nfsFromOptions = []}+ = fmap ((`withNfsOption` opts) . filter (".hs" `isSuffixOf`)) (getDirectoryContents ".")+ defaultNfs opts = return opts+