diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Jonathan Fischoff, Max Bolingbroke + +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 Jonathan Fischoff, Max Bolingbroke nor the names of other + 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 HOLDERS 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.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Test/Framework/Providers/Feat.hs b/src/Test/Framework/Providers/Feat.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Providers/Feat.hs @@ -0,0 +1,69 @@ +-- | Allows Feat properties to be used with the test-framework package. +-- +-- For an example of how to use test-framework, please see +-- +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TupleSections #-} +module Test.Framework.Providers.Feat (testFeat) where +import Test.Framework.Providers.API +import Test.Feat (values, Enumerable) +import Control.Arrow (second) +import Data.Typeable +import Debug.Trace + +-- | Create a 'Test' for a Feat property +testFeat :: (Enumerable a, Show a) => TestName -> (a -> Bool) -> Test +testFeat name = Test name . Property + +-- | Used to document numbers which we expect to be intermediate +-- test counts from running properties +-- I don't think I am using this in any meaningful way +type PropertyTestCount = Int + +instance TestResultlike PropertyTestCount PropertyStatus where + testSucceeded = propertySucceeded + +data PropertyStatus = PropertyOK + -- ^ The property is true as far as we could check it + | PropertyFalsifiable String + -- ^ The property was not true. The strings + -- are the reason and the output. + deriving(Show, Eq) + +propertySucceeded :: PropertyStatus -> Bool +propertySucceeded s = case s of + PropertyOK -> True + _ -> False + +data Property = forall a. (Enumerable a, Show a) => Property { unProperty :: a -> Bool } + deriving Typeable + +instance Testlike PropertyTestCount PropertyStatus Property where + runTest topts (Property testable) = runProperty topts testable + testTypeName _ = "Properties" + +traceIt x = trace (show x) x + +runProperty :: (Enumerable a, Show a) + => CompleteTestOptions + -> (a -> Bool) + -> IO (PropertyTestCount :~> PropertyStatus, IO ()) +runProperty topts test = do + let K count = topt_maximum_generated_tests topts + --This is just to help things type check + toValues :: (Enumerable a, Show a) => (a -> Bool) -> [(Integer, [a])] -> [(Integer, [a])] + toValues _ xs = xs + --There is probably a better way to get it to typecheck + values' = toValues test values + samples = take count . concatMap (\(i, xs) -> zip (repeat i) xs) . take count $ values' + results = map (second test) samples + + case map fst . filter ((==False) . snd . snd) . zip samples $ results of + [] -> return (Finished PropertyOK, return ()) + -- I could easily return all the results that sort was overwhelming + x:_ -> return . (, return ()) . Finished . PropertyFalsifiable . show $ x + diff --git a/test-framework-testing-feat.cabal b/test-framework-testing-feat.cabal new file mode 100644 --- /dev/null +++ b/test-framework-testing-feat.cabal @@ -0,0 +1,32 @@ +-- Initial test-framework-testing-feat.cabal generated by cabal init. For +-- further documentation, see http://haskell.org/cabal/users-guide/ + +name: test-framework-testing-feat +version: 0.1.0.0 +synopsis: A test framework provider for testing-feat +description: A test provider for testing-feat copied from test-framework-quickcheck2 by Max Bolingbroke +homepage: http://github.com/jfischoff/test-framework-testing-feat +license: BSD3 +license-file: LICENSE +author: Jonathan Fischoff, Max Bolingbroke +maintainer: jonathangfischoff@gmail.com +copyright: Copyright 2013 Jonathan Fischoff, Max Bolingbroke +category: Testing +build-type: Simple +cabal-version: >=1.8 + +library + exposed-modules: Test.Framework.Providers.Feat + build-depends: base == 4.*, + test-framework ==0.8.*, + testing-feat ==0.4.* + hs-source-dirs: src + +test-suite Tests + hs-source-dirs: src, tests + type: exitcode-stdio-1.0 + main-is: Main.hs + + build-depends: base == 4.*, + test-framework ==0.8.*, + testing-feat ==0.4.* diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-} +module Main where +import Test.Framework +import Test.Framework.Providers.Feat +import Test.Feat +import Data.Typeable +import Data.Monoid +import Control.Applicative +import Test.Framework.Options + +data Expr = Add Expr Expr + | I Int + deriving(Show, Read, Eq, Typeable) + +deriveEnumerable ''Expr + +showReadRoundTrip :: Expr -> Bool +showReadRoundTrip a = a == (read . show) a + +defOptions = mempty + +-- This should fail +showReadRoundTrip' :: Expr -> Bool +showReadRoundTrip' a = Add a a == (read . show) a + +main = defaultMainWithOpts [ + testFeat "should work" showReadRoundTrip + --, testFeat "this shouldn't" showReadRoundTrip' + ] (defOptions { ropt_test_options = (\x -> x { topt_maximum_generated_tests = Just 10000 }) <$> Just mempty })