diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/env runhaskell + +> import Distribution.Simple + +> main = defaultMain + diff --git a/hstest.cabal b/hstest.cabal new file mode 100644 --- /dev/null +++ b/hstest.cabal @@ -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 +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 + diff --git a/hstest.hs b/hstest.hs new file mode 100644 --- /dev/null +++ b/hstest.hs @@ -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 , 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 +