diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,37 +4,39 @@ [![Extrapolate Build Status][build-status]][build-log] [![Extrapolate on Hackage][hackage-version]][extrapolate-on-hackage] -Extrapolate automatically generalizes counter-examples to test properties. +Extrapolate is a property-based testing library for Haskell +capable of reporting generalized counter-examples. Example ------- -Consider the following (faulty) sort function and property: +Consider the following (faulty) sort function and a property about it: sort :: Ord a => [a] -> [a] - sort [] = [] - sort (x:xs) = sort (filter (< x) xs) - ++ [x] - ++ sort (filter (> x) xs) + sort [] = [] + sort (x:xs) = sort (filter (< x) xs) + ++ [x] + ++ sort (filter (> x) xs) prop_sortCount :: Ord a => a -> [a] -> Bool - prop_sortCount x xs = count x (sort xs) == count x xs + prop_sortCount x xs = count x (sort xs) == count x xs where count x = length . filter (== x) -Extrapolate both returns a fully defined counter-example along with a -generalization: +After testing the property, Extrapolate returns a fully defined counter-example +along with a generalization: > import Test.Extrapolate > check (prop_sortCount :: Int -> [Int] -> Bool) *** Failed! Falsifiable (after 4 tests): 0 [0,0] + Generalization: x (x:x:xs) -This hopefully makes it easier to find the source of the bug. -In this case, the faulty sort function discard repeated elements. +This hopefully makes it easier to find the source of the bug. In this case, +the faulty sort function discards repeated elements. More documentation diff --git a/TODO.md b/TODO.md --- a/TODO.md +++ b/TODO.md @@ -3,6 +3,24 @@ A non-exhaustive list of things TO DO for Extrapolate. + +bugs +---- + +* `stack-derivation`: + the current derivation mechanism cannot handle the following datatype: + + data Stack a = Stack a (Stack a) | Empty + + Change it to use `asTypeOf` instead of `argTypes0`. + +* `simplify-derived-instances`: + it seems to me that `argTypesN` is too complicated and unreliable and there + is a simpler solution. Maybe using sommething like `stack-derivation` but + for all other arities of constructors. For example, I don't think + `argTypesN` can handle the `Either` type. Test and see. + + examples -------- diff --git a/extrapolate.cabal b/extrapolate.cabal --- a/extrapolate.cabal +++ b/extrapolate.cabal @@ -1,5 +1,5 @@ name: extrapolate -version: 0.0.1 +version: 0.1.0 synopsis: generalize counter-examples of test properties description: Extrapolate is a tool able to provide generalized counter-examples of test @@ -31,7 +31,7 @@ source-repository this type: git location: https://github.com/rudymatela/speculate - tag: v0.0.1 + tag: v0.1.0 library exposed-modules: Test.Extrapolate @@ -43,13 +43,12 @@ , Test.Extrapolate.TypeBinding other-modules: Test.Extrapolate.Utils other-extensions: TemplateHaskell, CPP - build-depends: base >=4.9 && <4.10 - , leancheck + build-depends: base >= 4 && < 5 + , leancheck >= 0.6.4 , template-haskell - , speculate + , speculate >= 0.2.6 hs-source-dirs: src default-language: Haskell2010 - ghc-options: -dynamic test-suite test type: exitcode-stdio-1.0 @@ -57,9 +56,10 @@ hs-source-dirs: src, tests build-depends: base >= 4 && < 5, leancheck, speculate, template-haskell default-language: Haskell2010 - ghc-options: -dynamic --- NOTE: for some reason, my system is not able to compile extrapolate using --- cabal unless the -dynamic flag is present in ghc-options. I do not know if --- this affects other systems, so I am including it by default. --- -- Rudy 2017-08-01 +test-suite derive + type: exitcode-stdio-1.0 + main-is: test-derive.hs + hs-source-dirs: src, tests + build-depends: base >= 4 && < 5, leancheck, speculate, template-haskell + default-language: Haskell2010 diff --git a/src/Test/Extrapolate.hs b/src/Test/Extrapolate.hs --- a/src/Test/Extrapolate.hs +++ b/src/Test/Extrapolate.hs @@ -4,31 +4,70 @@ -- License : 3-Clause BSD (see the file LICENSE) -- Maintainer : Rudy Matela -- --- Extrapolate is a library for generalization of counter-examples. +-- Extrapolate is a property-based testing library capable of reporting +-- generalized counter-examples. -- -- Consider the following faulty implementation of sort: -- -- > sort :: Ord a => [a] -> [a] --- > sort [] = [] --- > sort (x:xs) = sort (filter (< x) xs) --- > ++ [x] --- > ++ sort (filter (> x) xs) +-- > sort [] = [] +-- > sort (x:xs) = sort (filter (< x) xs) +-- > ++ [x] +-- > ++ sort (filter (> x) xs) -- --- Extrapolate works like so: +-- When tests pass, Extrapolate works like a regular property-based testing +-- library. See: -- --- > > check $ \xs -> ordered (sort xs) --- > +++ OK, passed 360 tests! --- > > check $ \x xs -> count x (sort xs) == count x xs --- > *** Failed! Falsifiable (after 4 tests): --- > 0 [0,0] +-- > > check $ \xs -> sort (sort xs :: [Int]) == sort xs +-- > +++ OK, passed 360 tests. +-- +-- When tests fail, Extrapolate reports a fully defined counter-example and a +-- generalization of failing inputs. See: +-- +-- > > > check $ \xs -> length (sort xs :: [Int]) == length xs +-- > *** Failed! Falsifiable (after 3 tests): +-- > [0,0] +-- > -- > Generalization: --- > x (x:x:xs) +-- > x:x:_ +-- +-- The property fails for any integer @x@ and for any list @_@ at the tail. module Test.Extrapolate - ( module Test.Extrapolate.Core - , module Test.Extrapolate.Basic - , module Test.Extrapolate.Derive + ( +-- * Checking properties + check + , checkResult + , for + , withBackground + , withConditionSize + +-- * Obtaining generalizations + , counterExampleGen + , counterExampleGens + +-- * Generalizable types +-- | The following typeclass and functions are currently very hacky. +-- Expect them to change in the near future. + , Generalizable (..) + , this + , these + , usefuns + , nameOf + , Expr (..) + , constant, showConstant + +-- * Testable properties + , Testable + +-- ** Automatically deriving Generalizable instances + , deriveGeneralizable + , deriveGeneralizableIfNeeded + , deriveGeneralizableCascading + +-- * Other useful modules , module Test.Extrapolate.TypeBinding - , module Test.Extrapolate.IO + , module Test.LeanCheck + , module Test.LeanCheck.Utils.TypeBinding ) where @@ -37,3 +76,16 @@ import Test.Extrapolate.Derive import Test.Extrapolate.TypeBinding import Test.Extrapolate.IO + +import Test.LeanCheck hiding + ( Testable (..) + , results + , counterExamples + , counterExample + , productWith + , check + , checkFor + , checkResult + , checkResultFor + ) +import Test.LeanCheck.Utils.TypeBinding diff --git a/src/Test/Extrapolate/Core.hs b/src/Test/Extrapolate/Core.hs --- a/src/Test/Extrapolate/Core.hs +++ b/src/Test/Extrapolate/Core.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} -- for GHC <= 7.8 -- | -- Module : Test.Extrapolate.Core -- Copyright : (c) 2017 Rudy Matela @@ -19,6 +20,7 @@ , usefuns , (+++) , nameOf + , backgroundOf , Option (..) , options @@ -67,6 +69,7 @@ import Data.Maybe (listToMaybe, fromJust, isJust) import Data.Either (isRight) import Data.List (insert) +import Data.Functor ((<$>)) -- for GHC <= 7.8 import Test.Extrapolate.Exprs import Test.LeanCheck.Error (errorToFalse) @@ -76,6 +79,11 @@ useful _ = [] instances :: a -> Instances -> Instances instances _ = id +-- TODO: change Generalizable to include name and background: +-- name :: a -> String +-- background :: a -> [Expr] +-- Use the instance being declared itself on instances. +-- This is a _big change_: prototype first. instance Generalizable () where expr = showConstant @@ -177,6 +185,9 @@ getBackground :: Instances -> [Expr] getBackground is = concat [es | Instance "Background" _ es <- is] +backgroundOf :: Generalizable a => a -> [Expr] +backgroundOf x = getBackground $ instances x [] + -- | generalizes an expression by making it less defined, -- starting with smaller changes, then bigger changes: -- @@ -213,7 +224,7 @@ data Option = MaxTests Int | ExtraInstances Instances | MaxConditionSize Int - deriving Show + deriving (Show, Typeable) -- Typeable needed for GHC <= 7.8 data WithOption a = With { property :: a diff --git a/src/Test/Extrapolate/Derive.hs b/src/Test/Extrapolate/Derive.hs --- a/src/Test/Extrapolate/Derive.hs +++ b/src/Test/Extrapolate/Derive.hs @@ -21,7 +21,7 @@ ) where -import Test.Extrapolate.Core (Generalizable(..), Expr ((:$))) +import Test.Extrapolate.Core hiding (isInstanceOf) import Test.Extrapolate.TypeBinding import Language.Haskell.TH import Test.LeanCheck.Basic @@ -29,6 +29,7 @@ import Control.Monad (unless, liftM, liftM2, filterM) import Data.List (delete,nub,sort) import Data.Char (toLower) +import Data.Functor ((<$>)) -- for GHC <= 7.8 import Data.Typeable -- | Derives a 'Generalizable' instance for a given type 'Name'. @@ -44,9 +45,14 @@ -- will automatically derive the following 'Generalizable' instance: -- -- > instance Generalizable a => Generalizable (Stack a) where --- > tiers = cons2 Stack \/ cons0 Empty +-- > expr s@(Stack x y) = constant "Stack" (Stack ->>: s) :$ expr x :$ expr y +-- > expr s@Empty = constant "Empty" (Empty -: s) +-- > instances s = this "s" s +-- > $ let Stack x y = Stack undefined undefined `asTypeOf` s +-- > in instances x +-- > . instances y -- --- Needs the @TemplateHaskell@ extension. +-- This function needs the @TemplateHaskell@ extension. deriveGeneralizable :: Name -> DecsQ deriveGeneralizable = deriveGeneralizableX True False @@ -78,18 +84,24 @@ isEq <- t `isInstanceOf` ''Eq isOrd <- t `isInstanceOf` ''Ord (nt,vs) <- normalizeType t +#if __GLASGOW_HASKELL__ >= 710 cxt <- sequence [ [t| $(conT c) $(return v) |] +#else + -- template-haskell <= 2.9.0.0: + cxt <- sequence [ classP c [return v] +#endif | c <- ''Generalizable:([''Eq | isEq] ++ [''Ord | isOrd]) , v <- vs] cs <- typeConstructorsArgNames t + asName <- newName "x" let generalizableExpr = mergeIFns $ foldr1 mergeI - [ do argTypesN <- lookupValN $ "argTypes" ++ show (length ns) + [ do retTypeOf <- lookupValN $ "-" ++ replicate (length ns) '>' ++ ":" let exprs = [[| expr $(varE n) |] | n <- ns] - let conex = foldl AppE (VarE argTypesN) $ (ConE c:map VarE ns) - let root = [| constant $(stringE $ showJustName c) $(return conex) |] + let conex = [| $(varE retTypeOf) $(conE c) $(varE asName) |] + let root = [| constant $(stringE $ showJustName c) $(conex) |] let rhs = foldl (\e1 e2 -> [| $e1 :$ $e2 |]) root exprs [d| instance Generalizable $(return nt) where - expr ($(conP c (map varP ns))) = $rhs |] + expr $(asP asName $ conP c (map varP ns)) = $rhs |] | (c,ns) <- cs ] let generalizableInstances = do @@ -329,7 +341,11 @@ mergeIFns qds = do ds <- qds return $ map m' ds where +#if __GLASGOW_HASKELL__ < 800 + m' (InstanceD c ts ds) = InstanceD c ts [foldr1 m ds] +#else m' (InstanceD o c ts ds) = InstanceD o c ts [foldr1 m ds] +#endif FunD n cs1 `m` FunD _ cs2 = FunD n (cs1 ++ cs2) mergeI :: DecsQ -> DecsQ -> DecsQ @@ -337,13 +353,22 @@ ds2 <- qds2 return $ ds1 `m` ds2 where +#if __GLASGOW_HASKELL__ < 800 + [InstanceD c ts ds1] `m` [InstanceD _ _ ds2] = [InstanceD c ts (ds1 ++ ds2)] +#else [InstanceD o c ts ds1] `m` [InstanceD _ _ _ ds2] = [InstanceD o c ts (ds1 ++ ds2)] +#endif whereI :: DecsQ -> [Dec] -> DecsQ qds `whereI` w = do ds <- qds return $ map (`aw` w) ds +#if __GLASGOW_HASKELL__ < 800 + where aw (InstanceD c ts ds) w' = InstanceD c ts (ds++w') + aw d _ = d +#else where aw (InstanceD o c ts ds) w' = InstanceD o c ts (ds++w') aw d _ = d +#endif -- > nubMerge xs ys == nub (merge xs ys) -- > nubMerge xs ys == nub (sort (xs ++ ys)) diff --git a/src/Test/Extrapolate/Exprs.hs b/src/Test/Extrapolate/Exprs.hs --- a/src/Test/Extrapolate/Exprs.hs +++ b/src/Test/Extrapolate/Exprs.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} -- for GHC <= 7.8 -- | -- Module : Test.Extrapolate.IO -- Copyright : (c) 2017 Rudy Matela @@ -34,7 +35,7 @@ import qualified Test.Speculate.Expr as E import qualified Test.Speculate.Engine as E import Test.LeanCheck.Error (errorToFalse) -import Data.Typeable (typeOf, TypeRep) +import Data.Typeable (typeOf, TypeRep, Typeable) import Data.List ((\\)) canonicalizeWith :: Instances -> [Expr] -> [Expr] @@ -75,6 +76,7 @@ rs = [errorToFalse $ eval False e' | [e'] <- take m $ grounds is [e]] data MarkerType = MarkerType + deriving Typeable -- for GHC <= 7.8 fold :: [Expr] -> Expr fold [] = constant "[]" MarkerType diff --git a/src/Test/Extrapolate/IO.hs b/src/Test/Extrapolate/IO.hs --- a/src/Test/Extrapolate/IO.hs +++ b/src/Test/Extrapolate/IO.hs @@ -29,15 +29,35 @@ import Data.List (find, intercalate) import Control.Exception as E (SomeException, catch, evaluate) +-- | Use @`for`@ to configure the number of tests performed by @check@. +-- +-- > > check `for` 10080 $ \xs -> sort (sort xs) == sort (xs :: [Int]) +-- > +++ OK, passed 10080 tests. +-- +-- Don't forget the dollar (@$@)! for :: Testable a => (WithOption a -> b) -> Int -> a -> b check `for` m = \p -> check $ p `With` MaxTests m +-- | Allows the user to customize instance information available when generalized. +-- (For advanced users.) withInstances :: Testable a => (WithOption a -> b) -> Instances -> a -> b check `withInstances` is = \p -> check $ p `With` ExtraInstances is +-- | Use @`withBackground`@ to provide additional functions to appear in side-conditions. +-- +-- > check `withBackground` [constant "isSpace" isSpace] $ \xs -> unwords (words xs) == xs +-- > *** Failed! Falsifiable (after 4 tests): +-- > " " +-- > +-- > Generalization: +-- > ' ':_ +-- > +-- > Conditional Generalization: +-- > c:_ when isSpace c withBackground :: Testable a => (WithOption a -> b) -> [Expr] -> a -> b check `withBackground` ufs = check `withInstances` usefuns (undefined::Option) ufs +-- | Use @`withConditionSize`@ to configure the maximum condition size allowed. withConditionSize :: Testable a => (WithOption a -> b) -> Int -> a -> b check `withConditionSize` s = \p -> check $ p `With` MaxConditionSize s @@ -45,11 +65,13 @@ -- -- > > check $ \xs -> sort (sort xs) == sort (xs::[Int]) -- > +++ OK, passed 360 tests. +-- > -- > > check $ \xs ys -> xs `union` ys == ys `union` (xs::[Int]) -- > *** Failed! Falsifiable (after 4 tests): -- > [] [0,0] +-- > -- > Generalization: --- > [] (x:x:xs) +-- > [] (x:x:_) check :: Testable a => a -> IO () check p = checkResult p >> return () @@ -58,7 +80,7 @@ -- returning 'True' on success. -- -- There is no option to silence this function: --- for silence, you should use 'TestLean.Check.holds'. +-- for silence, you should use 'Test.LeanCheck.holds'. checkResult :: Testable a => a -> IO Bool checkResult p = do (r,ces) <- resultIO m p diff --git a/tests/test-derive.hs b/tests/test-derive.hs new file mode 100644 --- /dev/null +++ b/tests/test-derive.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, CPP #-} -- for GHC <= 7.8 +-- Copyright (c) 2017 Rudy Matela. +-- Distributed under the 3-Clause BSD licence (see the file LICENSE). +import Test +import Data.List (isPrefixOf) + +#if __GLASGOW_HASKELL__ < 710 +import Data.Typeable (Typeable) +deriving instance Typeable List +deriving instance Typeable Perhaps +deriving instance Typeable Ship +deriving instance Typeable Arrangement +deriving instance Typeable NonEmptyList +deriving instance Typeable Mutual +deriving instance Typeable Shared +deriving instance Typeable Tree +deriving instance Typeable Leafy +deriving instance Typeable Dict +#endif + +-- List is isomorphic to [] +data List a = Cons a (List a) + | Nil + deriving (Show, Eq, Ord) + +-- Perhaps is isomorphic to Maybe +data Perhaps a = Naught + | Simply a + deriving (Show, Eq, Ord) + +-- Ship is isomorphic to Either +data Ship a b = Port a + | Starboard b + deriving (Show, Eq, Ord) + +-- Arrangement is isomorphic to Ordering +data Arrangement = Lesser + | Equal + | Greater + deriving (Show, Eq, Ord) + +data NonEmptyList a = Buil a (NonEmptyList a) + | Unit a + deriving (Show, Eq, Ord) + +data Mutual a = Mutual a (Shared a) | M a deriving (Show, Eq, Ord) +data Shared a = Shared (Mutual a) a | S a deriving (Show, Eq, Ord) + +data Tree a = Node (Tree a) a (Tree a) | Empty + deriving (Show, Eq, Ord) + +data Leafy a = Branch (Leafy a) (Leafy a) | Leaf a + deriving (Show, Eq, Ord) + +data Dict a b = Meaning a b (Dict a b) + | End + deriving (Show, Eq, Ord) + + +-- Dummy undefined values -- + +ls :: a -> List a +ls = undefined + +perhaps :: a -> Perhaps a +perhaps = undefined + +ship :: a -> b -> Ship a b +ship = undefined + +arrangement :: Arrangement +arrangement = undefined + +nonEmptyList :: a -> NonEmptyList a +nonEmptyList = undefined + +mutual :: a -> Mutual a +mutual = undefined + +shared :: a -> Shared a +shared = undefined + +tree :: a -> Tree a +tree = undefined + +leafy :: a -> Leafy a +leafy = undefined + +dict :: a -> b -> Dict a b +dict = undefined + + +-- TODO: auto-derive Listable from deriveGeneralizable? +deriveListable ''List +deriveListable ''Perhaps +deriveListable ''Ship +deriveListable ''Arrangement + +deriveListable ''NonEmptyList + +deriveListable ''Mutual +deriveListable ''Shared + +deriveListable ''Tree +deriveListable ''Leafy + +deriveListable ''Dict + + +deriveGeneralizable ''List +{- -- derivation: +instance (Generalizable a) => Generalizable (List a) where + expr xs@Nil = constant "Nil" (Nil -: xs) + expr xs@(Cons y ys) = constant "Cons" (Cons ->>: xs) :$ expr y :$ expr ys + instances xs = this "xs" xs + $ instances (argTy1of1 xs) +-- note the use of -: and ->>: instead of argTypes +-} + +deriveGeneralizable ''Perhaps +{- -- derivation: +instance (Generalizable a) => Generalizable (Perhaps a) where + expr px@Naught = constant "Naught" (Naught -: px) + expr px@(Simply x) = constant "Simply" (Simply ->: px) :$ expr x + instances px = this "px" px + $ instances (argTy1of1 px) +-} + +deriveGeneralizable ''Ship +{- -- derivation: +instance (Generalizable a, Generalizable b) => Generalizable (Ship a b) where + expr s@(Port x) = constant "Port" (Port ->: s) :$ expr x + expr s@(Starboard y) = constant "Starboard" (Starboard ->: s) :$ expr y + instances s = this "s" s + $ instances (argTy1of2 s) + . instances (argTy2of2 s) +-} + +-- deriveGeneralizable ''Arrangement -- TODO: make this work + +deriveGeneralizable ''NonEmptyList + +deriveGeneralizable ''Mutual +deriveGeneralizable ''Shared + +deriveGeneralizable ''Tree +deriveGeneralizable ''Leafy + +deriveGeneralizable ''Dict + + +main :: IO () +main = mainTest tests 2160 + +tests :: Int -> [Bool] +tests n = + [ True + + , holds n $ generalizableOK -:> ls int + , holds n $ generalizableOK -:> ls bool + , holds n $ generalizableOK -:> perhaps int + , holds n $ generalizableOK -:> perhaps bool + , holds n $ generalizableOK -:> ship int int + , holds n $ generalizableOK -:> ship bool () +--, holds n $ generalizableOK -:> arrangement -- TODO: make this work + , holds n $ generalizableOK -:> mutual int + , holds n $ generalizableOK -:> mutual bool + , holds n $ generalizableOK -:> shared int + , holds n $ generalizableOK -:> shared bool + , holds n $ generalizableOK -:> tree int + , holds n $ generalizableOK -:> tree bool + , holds n $ generalizableOK -:> leafy int + , holds n $ generalizableOK -:> leafy bool + , holds n $ generalizableOK -:> dict int bool + , holds n $ generalizableOK -:> dict bool int + ] + + +generalizableOK :: (Eq a, Show a, Generalizable a) => a -> Bool +generalizableOK x = idExprEval x && showOK x + +idExprEval :: (Eq a, Generalizable a) => a -> Bool +idExprEval x = eval (error "idExprEval: could not eval") (expr x) == x + +showOK :: (Show a, Generalizable a) => a -> Bool +showOK x = show x == dropType (show (expr x)) + where + dropType :: String -> String + dropType cs | " :: " `isPrefixOf` cs = "" + dropType "" = "" + dropType (c:cs) = c : dropType cs diff --git a/tests/test-extrapolate.hs b/tests/test-extrapolate.hs --- a/tests/test-extrapolate.hs +++ b/tests/test-extrapolate.hs @@ -2,10 +2,145 @@ -- Distributed under the 3-Clause BSD licence (see the file LICENSE). import Test +import Data.List (sort) + main :: IO () main = mainTest tests 10000 tests :: Int -> [Bool] tests n = [ True + + -- Transforming lists into Exprs + , expr ([]::[Int]) == constant "[]" ([]::[Int]) + , expr ([0::Int]) == zero -:- ll + , expr ([0::Int,1]) == zero -:- one -:- ll + , holds n $ \xs -> expr xs == foldr (-:-) ll (map expr (xs :: [Int])) + , holds n $ \ps -> expr ps == foldr (-:-) llb (map expr (ps :: [Bool])) + + -- Transforming Maybes into Exprs + , expr (Nothing :: Maybe Int) == nothing + , expr (Nothing :: Maybe Bool) == nothingBool + , expr (Just 1 :: Maybe Int) == just one + , expr (Just False :: Maybe Bool) == just false + , holds n $ \x -> expr (Just x) == just (expr (x :: Int)) + , holds n $ \p -> expr (Just p) == just (expr (p :: Bool)) + + -- Transforming Tuples into Exprs + , expr ((0,False) :: (Int,Bool)) == zero `comma` false + , expr ((True,1) :: (Bool,Int)) == true `comma` one + + -- Showing of Exprs + , holds n $ \x -> show (expr x) == show (x :: ()) ++ " :: ()" + , holds n $ \x -> show (expr x) == show (x :: Int) ++ " :: Int" + , holds n $ \p -> show (expr p) == show (p :: Bool) ++ " :: Bool" + , holds n $ \x -> show (expr x) == show (x :: Integer) ++ " :: Integer" + + , holds 9 $ \xs -> show (expr xs) == show (xs :: [()]) ++ " :: [()]" + , holds n $ \xs -> show (expr xs) == show (xs :: [Int]) ++ " :: [Int]" + , holds n $ \ps -> show (expr ps) == show (ps :: [Bool]) ++ " :: [Bool]" + , holds n $ \xs -> show (expr xs) == show (xs :: [Integer]) ++ " :: [Integer]" + + , holds n $ \mx -> show (expr mx) == show (mx :: Maybe ()) ++ " :: Maybe ()" + , holds n $ \mx -> show (expr mx) == show (mx :: Maybe Int) ++ " :: Maybe Int" + , holds n $ \mp -> show (expr mp) == show (mp :: Maybe Bool) ++ " :: Maybe Bool" + , holds n $ \mx -> show (expr mx) == show (mx :: Maybe Integer) ++ " :: Maybe Integer" + + , holds n $ \xy -> show (expr xy) == show (xy :: ((),Int)) ++ " :: ((),Int)" + , holds n $ \xy -> show (expr xy) == show (xy :: (Bool,Integer)) ++ " :: (Bool,Integer)" + , holds n $ \xyz -> show (expr xyz) == show (xyz :: ((),Int,Bool)) ++ " :: ((),Int,Bool)" +-- TODO: implement further tuple instances (4,5,6) and uncomment below +--, holds n $ \xyzw -> show (expr xyzw) +-- == show (xyzw :: ((),Int,Integer,Bool)) ++ " :: ((),Int,Integer,Bool)" +--, holds n $ \xyzwv -> show (expr xyzwv) +-- == show (xyzwv :: ((),Int,Integer,Bool,())) ++ " :: ((),Int,Integer,Bool,())" +--, holds n $ \xyzwvu -> show (expr xyzwvu) +-- == show (xyzwvu :: ((),Int,Integer,Bool,(),Int)) ++ " :: ((),Int,Integer,Bool,(),Int)" + + , holds n $ idExprEval -:> () + , holds n $ idExprEval -:> int + , holds n $ idExprEval -:> integer + , holds n $ idExprEval -:> bool + , holds n $ idExprEval -:> char + , holds 9 $ idExprEval -:> [()] + , holds n $ idExprEval -:> [int] + , holds n $ idExprEval -:> [integer] + , holds n $ idExprEval -:> [bool] + , holds n $ idExprEval -:> [char] + , holds n $ idExprEval -:> (mayb ()) + , holds n $ idExprEval -:> (mayb int) + , holds n $ idExprEval -:> (mayb integer) + , holds n $ idExprEval -:> (mayb bool) + , holds n $ idExprEval -:> (mayb char) + , holds n $ idExprEval -:> (int,bool) + , holds n $ idExprEval -:> ((),integer) + , holds n $ idExprEval -:> ((),bool,integer) +-- TODO: implement further tuple instances (4,5,6) and uncomment below +--, holds n $ idExprEval -:> (int,(),bool,integer) +--, holds n $ idExprEval -:> (int,(),bool,integer,char) +--, holds n $ idExprEval -:> (string,int,(),bool,integer,char) +-- TODO: implement further tuple instances (7,8,9,10,11,12) and uncomment below +--, holds n $ idExprEval -:> ((),(),(),(),(),(),()) +--, holds n $ idExprEval -:> ((),(),(),(),(),(),(),()) +--, holds n $ idExprEval -:> ((),(),(),(),(),(),(),(),()) +--, holds n $ idExprEval -:> ((),(),(),(),(),(),(),(),(),()) +--, holds n $ idExprEval -:> ((),(),(),(),(),(),(),(),(),(),()) +--, holds n $ idExprEval -:> ((),(),(),(),(),(),(),(),(),(),(),()) + + + -- Silly test, as it basically replicates the actual implementation: + , backgroundOf int =$ sort $= [ constant "==" $ (==) -:> int + , constant "/=" $ (/=) -:> int + , constant "<=" $ (<=) -:> int + , constant "<" $ (<) -:> int + ] + + -- background tests + , listBackgroundOK () + , listBackgroundOK int + , listBackgroundOK integer + , listBackgroundOK bool + , listBackgroundOK char + , listBackgroundOK [()] + , listBackgroundOK [int] + , listBackgroundOK [integer] + , listBackgroundOK [bool] + , listBackgroundOK [char] + , listBackgroundOK (mayb ()) + , listBackgroundOK (mayb int) + , listBackgroundOK (mayb integer) + , listBackgroundOK (mayb bool) + , listBackgroundOK (mayb char) + + , maybeBackgroundOK () + , maybeBackgroundOK int + , maybeBackgroundOK integer + , maybeBackgroundOK bool + , maybeBackgroundOK char + , maybeBackgroundOK [()] + , maybeBackgroundOK [int] + , maybeBackgroundOK [integer] + , maybeBackgroundOK [bool] + , maybeBackgroundOK [char] + , maybeBackgroundOK (mayb ()) + , maybeBackgroundOK (mayb int) + , maybeBackgroundOK (mayb integer) + , maybeBackgroundOK (mayb bool) + , maybeBackgroundOK (mayb char) ] + +idExprEval :: (Eq a, Generalizable a) => a -> Bool +idExprEval x = eval (error "idExprEval: could not eval") (expr x) == x + +listBackgroundOK :: Generalizable a => a -> Bool +listBackgroundOK x = backgroundOf [x] =$ sort $= backgroundListOf x + where + backgroundListOf x = [ constant "length" $ length -:> [x] + , constant "filter" $ filter ->:> [x] + ] + +++ backgroundOf x + +maybeBackgroundOK :: Generalizable a => a -> Bool +maybeBackgroundOK x = backgroundOf (mayb x) =$ sort $= backgroundMaybeOf x + where + backgroundMaybeOf x = [constant "Just" $ Just -:> x] +++ backgroundOf x