diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,13 +4,85 @@ [![Extrapolate Build Status][build-status]][build-log] [![Extrapolate on Hackage][hackage-version]][extrapolate-on-hackage] -Extrapolate is a property-based testing library for Haskell +Extrapolate is a [property-based testing] library for [Haskell] capable of reporting generalized counter-examples. -Example -------- +Installing Extrapolate +---------------------- +To install the latest version of [Extrapolate from Hackage] using [cabal], just: + + $ cabal update + $ cabal install extrapolate + +To test if it installed correctly, follow through the next section. + + +Using Extrapolate +----------------- + +To use Extrapolate, you first import the [`Test.Extrapolate`] module, +then pass any properties you with to test to the function [`check`]: + + $ ghci + > import Test.Extrapolate + > check $ \x y -> x + y == y + (x :: Int) + +++ OK, passed 360 tests. + + > import Data.List (nub) + > check $ \xs -> nub xs == (xs :: [Int]) + *** Failed! Falsifiable (after 3 tests): + [0,0] + + Generalization: + x:x:_ + +The operator [`+`] is commutative. The function [`nub`] is not an identity. + + +### Configuring the number of tests + +To increase the number of tests, use the [`for`] combinator: + + $ ghci + > import Test.Extrapolate + > check `for` 1000 $ \x y -> x + y == y + (x :: Int) + +++ OK, passed 1000 tests. + + +### Customizing the background functions (allowed in side-conditions) + +To customize the background functions, use the [`withBackground`] combinator: + + $ ghci + > import Test.Extrapolate + > import Data.List (nub) + > let hasDups xs = nub xs /= (xs :: [Int]) + > check `withBackground` [constant "hasDups" hasDups] $ \xs -> nub xs == (xs :: [Int]) + *** Failed! Falsifiable (after 3 tests): + [0,0] + + Generalization: + x:x:_ + + Conditional Generalization: + xs when hasDups xs + +Perhaps the example above is silly (`hasDups` is the negation of the property +itself!), but it illustrates the use of [`withBackground`]. + + +The combinators [`for`] and [`withBackground`] can be used in conjunction: + + > check `for` 100 `withBackground` [...] $ property + +Don't forget the dollar sign [`$`]. + + +Another Example +--------------- + Consider the following (faulty) sort function and a property about it: sort :: Ord a => [a] -> [a] @@ -33,18 +105,33 @@ 0 [0,0] Generalization: - x (x:x:xs) + x (x:x:_) This hopefully makes it easier to find the source of the bug. In this case, the faulty sort function discards repeated elements. -More documentation ------------------- +Further reading +--------------- For more examples, see the [eg](eg) folder. +For type signatures, other options and uses, +see [Extrapolate's API documentation]. -[build-status]: https://travis-ci.org/rudymatela/extrapolate.svg?branch=master -[build-log]: https://travis-ci.org/rudymatela/extrapolate +[extrapolate-on-hackage]: https://hackage.haskell.org/package/extrapolate +[Extrapolate from Hackage]: https://hackage.haskell.org/package/extrapolate +[Extrapolate's API documentation]: https://hackage.haskell.org/package/extrapolate/docs/Test-Extrapolate.html +[`Test.Extrapolate`]: https://hackage.haskell.org/package/extrapolate/docs/Test-Extrapolate.html +[`check`]: https://hackage.haskell.org/package/extrapolate/docs/Test-Extrapolate.html#v:check +[`for`]: https://hackage.haskell.org/package/extrapolate/docs/Test-Extrapolate.html#v:for +[`withBackground`]: https://hackage.haskell.org/package/extrapolate/docs/Test-Extrapolate.html#v:withBackground +[`$`]: https://hackage.haskell.org/package/base-4.10.0.0/docs/Prelude.html#v:-36- +[`+`]: https://hackage.haskell.org/package/base/docs/Prelude.html#v:-43- +[`nub`]: https://hackage.haskell.org/package/base/docs/Data-List.html#v:nub +[Haskell]: https://www.haskell.org/ +[cabal]: https://www.haskell.org/cabal/ +[property-based testing]: https://github.com/rudymatela/leancheck/blob/master/doc/tutorial.md + +[build-status]: https://travis-ci.org/rudymatela/extrapolate.svg?branch=master +[build-log]: https://travis-ci.org/rudymatela/extrapolate [hackage-version]: https://img.shields.io/hackage/v/extrapolate.svg -[extrapolate-on-hackage]: https://hackage.haskell.org/package/extrapolate diff --git a/TODO.md b/TODO.md --- a/TODO.md +++ b/TODO.md @@ -4,21 +4,23 @@ A non-exhaustive list of things TO DO for Extrapolate. -bugs ----- - -* `stack-derivation`: - the current derivation mechanism cannot handle the following datatype: +cleanup +------- - data Stack a = Stack a (Stack a) | Empty +* `renames1`: + rename show functions: + - move `showCE` to `Core`; + - add and use `Core.showCCE`; + - rename `IO.showCEC` to `IO.showCEandGens`; - Change it to use `asTypeOf` instead of `argTypes0`. +* `renames2`: + rename counterexamples: + - rename `counterExamples*` to `counterExamples*E`; + - add `counterExamples* :: ... String ...`; -* `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. +* `cleanup`: + cleanup and remove unused functions, like `showCEG`; + thighten exports, removing uneeded functions (`backgroundWith`). examples diff --git a/extrapolate.cabal b/extrapolate.cabal --- a/extrapolate.cabal +++ b/extrapolate.cabal @@ -1,5 +1,5 @@ name: extrapolate -version: 0.1.0 +version: 0.2.0 synopsis: generalize counter-examples of test properties description: Extrapolate is a tool able to provide generalized counter-examples of test @@ -22,7 +22,7 @@ extra-doc-files: README.md , TODO.md -tested-with: GHC==8.0 +tested-with: GHC==8.0, GHC==7.10, GHC==7.8 source-repository head type: git @@ -31,7 +31,7 @@ source-repository this type: git location: https://github.com/rudymatela/speculate - tag: v0.1.0 + tag: v0.2.0 library exposed-modules: Test.Extrapolate diff --git a/src/Test/Extrapolate.hs b/src/Test/Extrapolate.hs --- a/src/Test/Extrapolate.hs +++ b/src/Test/Extrapolate.hs @@ -41,20 +41,13 @@ , 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 + , bgEq + , bgOrd -- * Testable properties , Testable @@ -68,6 +61,7 @@ , module Test.Extrapolate.TypeBinding , module Test.LeanCheck , module Test.LeanCheck.Utils.TypeBinding + , ordering ) where @@ -89,3 +83,8 @@ , checkResultFor ) import Test.LeanCheck.Utils.TypeBinding +-- TODO: add the following function `ordering` into LeanCheck's TypeBinding +-- module; release a new LeanCheck; remove it from here and bump version +-- requirement. +ordering :: Ordering +ordering = undefined diff --git a/src/Test/Extrapolate/Basic.hs b/src/Test/Extrapolate/Basic.hs --- a/src/Test/Extrapolate/Basic.hs +++ b/src/Test/Extrapolate/Basic.hs @@ -19,6 +19,7 @@ instance (Integral a, Generalizable a) => Generalizable (Ratio a) where expr = showConstant - instances q = this "q" q id + name _ = "q" + instances q = this q id -- The following would allow zero denominators -- expr (n % d) = constant "%" ((%) -:> n) :$ expr n :$ expr d 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 @@ -16,11 +16,11 @@ , Generalizable (..) , this - , these - , usefuns + , backgroundWith , (+++) - , nameOf , backgroundOf + , bgEq + , bgOrd , Option (..) , options @@ -72,115 +72,152 @@ import Data.Functor ((<$>)) -- for GHC <= 7.8 import Test.Extrapolate.Exprs import Test.LeanCheck.Error (errorToFalse) +import Test.Extrapolate.TypeBinding -- for Haddock +-- | Extrapolate can generalize counter-examples of any types that are +-- 'Generalizable'. +-- +-- The core (and only required functions) of the generalizable typeclass are +-- the 'expr' and 'instances' functions. +-- +-- The following example shows a datatype and its instance: +-- +-- > data Stack a = Stack a (Stack a) | Empty +-- +-- > instance Generalizable a => Generalizable (Stack a) where +-- > name _ = "s" +-- > expr s@(Stack x y) = constant "Stack" (Stack ->>: s) :$ expr x :$ expr y +-- > expr s@Empty = constant "Empty" (Empty -: s) +-- > instances s = this s $ instances (argTy1of1 s) +-- +-- To declare 'instances' and 'expr' it may be useful to use: +-- +-- * LeanCheck's "Test.LeanCheck.Utils.TypeBinding" operators: +-- '-:', '->:', '->>:', ...; +-- * Extrapolate's "Test.Extrapolate.TypeBinding" operators: +-- 'argTy1of1', 'argTy1of2', 'argTy2of2', .... class (Listable a, Typeable a, Show a) => Generalizable a where + -- | Transforms a value into an manipulable expression tree. + -- See 'constant' and ':$'. expr :: a -> Expr - useful :: a -> [Expr] - useful _ = [] + + -- | Common name for a variable, defaults to @"x"@. + name :: a -> String + name _ = "x" + + -- | List of symbols allowed to appear in side-conditions. + -- Defaults to @[]@. See 'constant'. + background :: a -> [Expr] + background _ = [] + + -- | Computes a list of reified instances. See 'this'. 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 - instances u = this "u" u id + name _ = "u" + instances u = this u id instance Generalizable Bool where expr = showConstant - instances p = these "p" p - [ constant "not" not ] - $ id + name _ = "p" + background _ = [ constant "not" not ] + instances p = this p id instance Generalizable Int where expr = showConstant - instances x = these "x" x - [ constant "==" ((==) -:> x) - , constant "/=" ((/=) -:> x) - , constant "<" ((<) -:> x) - , constant "<=" ((<=) -:> x) - ] - $ id + name _ = "x" + background x = bgOrd x + instances x = this x id instance Generalizable Integer where expr = showConstant - instances x = these "x" x - [ constant "==" ((==) -:> x) - , constant "/=" ((/=) -:> x) - , constant "<" ((<) -:> x) - , constant "<=" ((<=) -:> x) ] - $ id + name _ = "x" + background x = bgOrd x + instances x = this x id instance Generalizable Char where expr = showConstant - instances c = these "c" c - [ constant "==" ((==) -:> c) - , constant "/=" ((/=) -:> c) - , constant "<" ((<) -:> c) - , constant "<=" ((<=) -:> c) ] - $ id + name _ = "c" + background c = bgOrd c + instances c = this c id instance (Generalizable a) => Generalizable (Maybe a) where expr mx@Nothing = constant "Nothing" (Nothing -: mx) expr mx@(Just x) = constant "Just" (Just ->: mx) :$ expr x - instances mx = these "mx" mx - [ constant "Just" (Just ->: mx) ] - $ instances (fromJust mx) + name mx = "m" ++ name (fromJust mx) + background mx = [ constant "Just" (Just ->: mx) ] + instances mx = this mx $ instances (fromJust mx) +instance (Generalizable a, Generalizable b) => Generalizable (Either a b) where + expr lx@(Left x) = constant "Left" (Left ->: lx) :$ expr x + expr ry@(Right y) = constant "Right" (Right ->: ry) :$ expr y + name exy = "e" ++ name (fromLeft exy) ++ name (fromRight exy) + background exy = [ constant "Left" (Left ->: exy) + , constant "Right" (Right ->: exy) ] + instances exy = this exy $ instances (fromLeft exy) + . instances (fromRight exy) + instance (Generalizable a, Generalizable b) => Generalizable (a,b) where + name xy = name (fst xy) ++ name (snd xy) expr (x,y) = constant "," ((,) ->>: (x,y)) :$ expr x :$ expr y - instances xy = this "xy" xy $ instances (fst xy) - . instances (snd xy) + instances xy = this xy $ instances (fst xy) + . instances (snd xy) instance (Generalizable a, Generalizable b, Generalizable c) => Generalizable (a,b,c) where + name xyz = name ((\(x,_,_) -> x) xyz) + ++ name ((\(_,y,_) -> y) xyz) + ++ name ((\(_,_,z) -> z) xyz) expr (x,y,z) = constant ",," ((,,) ->>>: (x,y,z)) :$ expr x :$ expr y :$ expr z - instances xyz = this "xyz" xyz $ instances (fst xyz) - . instances (snd xyz) - . instances (trd xyz) + instances xyz = this xyz $ instances (fst xyz) + . instances (snd xyz) + . instances (trd xyz) where fst (x,_,_) = x snd (_,y,_) = y trd (_,_,z) = z instance Generalizable a => Generalizable [a] where + name xs = name (head xs) ++ "s" expr (xs@[]) = showConstant ([] -: xs) expr (xs@(y:ys)) = constant ":" ((:) ->>: xs) :$ expr y :$ expr ys - instances xs = these (nameOf (head xs) ++ "s") xs - [ constant "length" (length -:> xs) - , constant "filter" (filter ->:> xs) ] - $ instances (head xs) + background xs = [ constant "length" (length -:> xs) + , constant "filter" (filter ->:> xs) ] + instances xs = this xs $ instances (head xs) -nameOf :: Generalizable a => a -> String -nameOf x = head $ names (instances x []) (typeOf x) +instance Generalizable Ordering where + name o = "o" + expr o = showConstant o + background o = bgOrd o + instances o = this o id --- | Usage: @ins "x" (undefined :: Type)@ -ins :: (Typeable a, Listable a, Show a) - => String -> a -> Instances -ins n x = listable x +++ name n x +bgEq :: (Eq a, Generalizable a) => a -> [Expr] +bgEq x = [ constant "==" ((==) -:> x) + , constant "/=" ((/=) -:> x) ] -this :: (Typeable a, Listable a, Show a) - => String -> a -> (Instances -> Instances) -> Instances -> Instances -this n x f is = - if isListable is (typeOf x) - then is - else f (ins n x +++ is) +bgOrd :: (Ord a, Generalizable a) => a -> [Expr] +bgOrd x = [ constant "==" ((==) -:> x) + , constant "/=" ((/=) -:> x) + , constant "<" ((<) -:> x) + , constant "<=" ((<=) -:> x) ] --- bad function naming! -these :: (Typeable a, Listable a, Show a) - => String -> a -> [Expr] -> (Instances -> Instances) -> Instances -> Instances -these n x es f is = +-- | Usage: @ins "x" (undefined :: Type)@ +ins :: Generalizable a => a -> Instances +ins x = listable x +++ nameWith (name x) x +++ backgroundWith (background x) x + +this :: Generalizable a + => a -> (Instances -> Instances) -> Instances -> Instances +this x f is = if isListable is (typeOf x) then is - else f (listable x +++ name n x +++ usefuns x es +++ is) + else f (ins x +++ is) +-- TODO: change type to a -> [Instances -> Instances] -> Instances -> Instances --- bad function naming! -usefuns :: Typeable a => a -> [Expr] -> Instances -usefuns x es = [ Instance "Background" (typeOf x) es ] +backgroundWith :: Typeable a => [Expr] -> a -> Instances +backgroundWith es x = [ Instance "Background" (typeOf x) es ] getBackground :: Instances -> [Expr] getBackground is = concat [es | Instance "Background" _ es <- is] 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 @@ -31,6 +31,7 @@ import Data.Char (toLower) import Data.Functor ((<$>)) -- for GHC <= 7.8 import Data.Typeable +import Test.Extrapolate.Utils (foldr0) -- | Derives a 'Generalizable' instance for a given type 'Name'. -- @@ -104,30 +105,35 @@ expr $(asP asName $ conP c (map varP ns)) = $rhs |] | (c,ns) <- cs ] - let generalizableInstances = do + let generalizableBackground = do n <- newName "x" - let rhs = foldr1 (\e1 e2 -> [| $e1 . $e2 |]) - [letin n c ns | (c,ns) <- cs, not (null ns)] case (isEq, isOrd) of (True, True) -> - [d| instance Generalizable $(return nt) where - instances $(varP n) = these $(stringE vname) $(varE n) - [ constant "==" ((==) -:> $(varE n)) + [d| instance Generalizable $(return nt) where + background $(varP n) = [ constant "==" ((==) -:> $(varE n)) , constant "/=" ((/=) -:> $(varE n)) , constant "<" ((<) -:> $(varE n)) - , constant "<=" ((<=) -:> $(varE n)) ] - $ $rhs |] + , constant "<=" ((<=) -:> $(varE n)) ] |] (True, False) -> - [d| instance Generalizable $(return nt) where - instances $(varP n) = these $(stringE vname) $(varE n) - [ constant "==" ((==) -:> $(varE n)) - , constant "/=" ((/=) -:> $(varE n)) ] - $ $rhs |] + [d| instance Generalizable $(return nt) where + background $(varP n) = [ constant "==" ((==) -:> $(varE n)) + , constant "/=" ((/=) -:> $(varE n)) ] |] (False, False) -> - [d| instance Generalizable $(return nt) where - instances $(varP n) = this $(stringE vname) $(varE n) $ $rhs |] + [d| instance Generalizable $(return nt) where + background $(varP n) = [] |] _ -> error $ "reallyDeriveGeneralizable " ++ show t ++ ": the impossible happened" - cxt |=>| (generalizableExpr `mergeI` generalizableInstances) + let generalizableInstances = do + n <- newName "x" + let lets = [letin n c ns | (c,ns) <- cs, not (null ns)] + let rhs = foldr0 (\e1 e2 -> [| $e1 . $e2 |]) [|id|] lets + [d| instance Generalizable $(return nt) where + instances $(varP n) = this $(varE n) $ $rhs |] + let generalizableName = do + [d| instance Generalizable $(return nt) where + name _ = $(stringE vname) |] + cxt |=>| (generalizableName `mergeI` generalizableExpr + `mergeI` generalizableBackground + `mergeI` generalizableInstances) where showJustName = reverse . takeWhile (/= '.') . reverse . show vname = map toLower . take 1 $ showJustName t 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 @@ -20,6 +20,7 @@ , fold , unfold , isAssignmentTest + , nameWith , module Test.Speculate.Expr ) @@ -27,6 +28,7 @@ import Test.Speculate.Expr hiding ( ins + , name , canonicalizeWith , grounds , vassignments @@ -37,6 +39,9 @@ import Test.LeanCheck.Error (errorToFalse) import Data.Typeable (typeOf, TypeRep, Typeable) import Data.List ((\\)) + +nameWith :: Typeable a => String -> a -> Instances +nameWith = E.name canonicalizeWith :: Instances -> [Expr] -> [Expr] canonicalizeWith is = unfold . canonicalizeWith1 is . unrepeatedToHole1 . fold 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 @@ -55,7 +55,7 @@ -- > Conditional Generalization: -- > c:_ when isSpace c withBackground :: Testable a => (WithOption a -> b) -> [Expr] -> a -> b -check `withBackground` ufs = check `withInstances` usefuns (undefined::Option) ufs +check `withBackground` ufs = check `withInstances` backgroundWith ufs (undefined::Option) -- | Use @`withConditionSize`@ to configure the maximum condition size allowed. withConditionSize :: Testable a => (WithOption a -> b) -> Int -> a -> b @@ -121,53 +121,27 @@ showResult m p ces (OK n) = "+++ OK, passed " ++ show n ++ " tests" ++ takeWhile (\_ -> n < m) " (exhausted)" ++ ".\n\n" showResult m p ces (Falsified i ce) = "*** Failed! Falsifiable (after " - ++ show i ++ " tests):\n" ++ showCEC m p ce + ++ show i ++ " tests):\n" ++ showCEandGens m p ce showResult m p ces (Exception i ce e) = "*** Failed! Exception '" ++ e ++ "' (after " - ++ show i ++ " tests):\n" ++ showCEC m p ce + ++ show i ++ " tests):\n" ++ showCEandGens m p ce -showCEC :: Testable a => Int -> a -> [Expr] -> String -showCEC m p es = showCE es ++ "\n\n" +showCEandGens :: Testable a => Int -> a -> [Expr] -> String +showCEandGens m p es = showCE es ++ "\n\n" ++ case generalizationsCE m p es of [] -> "" (es:_) -> "Generalization:\n" ++ showCE es ++ "\n\n" ++ case generalizationsCEC m p es of [] -> "" - ((c,es):_) -> "Conditional Generalization:\n" - ++ showCE es ++ " when " - ++ showPrecExpr 0 (prettify c) ++ "\n\n" - -showCEG :: Testable a => Int -> a -> [[Expr]] -> [Expr] -> String -showCEG m p ces es = showCE es ++ "\n\n" - ++ case mg00 of - Nothing -> "" - Just es -> "Generalization, 100% failure, " - ++ show (count (`areInstancesOf` es) ces * 100 `div` m) ++ "% match:\n" - ++ showCE es ++ "\n\n" - ++ case (mg10 /= mg00, mg10) of - (True, Just es) -> "Generalization, >90% failure, " - ++ show (count (`areInstancesOf` es) ces * 100 `div` m) ++ "% match:\n" - ++ showCE es ++ "\n\n" - _ -> "" - ++ case (mg10 /= mg00, mg00, mg10) of - (True, Just es0, Just es1) -> showCGen es0 es1 - (True, Nothing, Just es1) -> showCGen es es1 - _ -> "" - where - gcs = generalizationsCounts m p es - mg00 = listToMaybe [es | (es,0) <- gcs] - mg10 = listToMaybe [es | (es,n) <- gcs, n <= m `div` 12] - count p = length . filter p - showCGen es0 es1 = case conditionalGeneralization m p es0 es1 of - Nothing -> "" - Just (cs,es) -> "Generalization, 100% failure:\n" - ++ showCE es ++ " when " - ++ intercalate ", " [showPrecExpr 0 c | c <- cs] - ++ "\n\n" + (es:_) -> "Conditional Generalization:\n" + ++ showCCE es ++ "\n\n" showCE :: [Expr] -> String showCE [e] = showPrecExpr 0 e showCE es = unwords [showPrecExpr 11 e | e <- es] + +showCCE :: (Expr,[Expr]) -> String +showCCE (c,es) = showCE es ++ " when " ++ showPrecExpr 0 (prettify c) -- WARNING: expressions are unevaluable after this, just good for printing prettify :: Expr -> Expr diff --git a/src/Test/Extrapolate/TypeBinding.hs b/src/Test/Extrapolate/TypeBinding.hs --- a/src/Test/Extrapolate/TypeBinding.hs +++ b/src/Test/Extrapolate/TypeBinding.hs @@ -36,6 +36,10 @@ ) where +-- TODO: reexport LeanCheck's typebinding operators + +-- TODO: remove argTypesN and argTysN, unused and uneeded + argTypes0 :: a -> a argTypes0 f = f diff --git a/src/Test/Extrapolate/Utils.hs b/src/Test/Extrapolate/Utils.hs --- a/src/Test/Extrapolate/Utils.hs +++ b/src/Test/Extrapolate/Utils.hs @@ -13,6 +13,9 @@ , nubMerge , nubMergeOn , nubMergeBy + , foldr0 + , fromLeft + , fromRight ) where @@ -34,3 +37,18 @@ (+++) :: Ord a => [a] -> [a] -> [a] (+++) = nubMerge infixr 5 +++ + +-- variation of foldr that only uses "zero" when the list is empty +foldr0 :: (a -> a -> a) -> a -> [a] -> a +foldr0 f z xs | null xs = z + | otherwise = foldr1 f xs + +-- note these versions of fromLeft and fromRight differ from the ones of +-- Data.Either since 4.10.0.0. +fromLeft :: Either a b -> a +fromLeft (Left x) = x +fromLeft _ = error "fromLeft: not a left" + +fromRight :: Either a b -> b +fromRight (Right x) = x +fromRight _ = error "fromRight: not a right" diff --git a/tests/test-derive.hs b/tests/test-derive.hs --- a/tests/test-derive.hs +++ b/tests/test-derive.hs @@ -3,7 +3,7 @@ -- Copyright (c) 2017 Rudy Matela. -- Distributed under the 3-Clause BSD licence (see the file LICENSE). import Test -import Data.List (isPrefixOf) +import Data.List (sort) #if __GLASGOW_HASKELL__ < 710 import Data.Typeable (Typeable) @@ -17,6 +17,9 @@ deriving instance Typeable Tree deriving instance Typeable Leafy deriving instance Typeable Dict +deriving instance Typeable Data +deriving instance Typeable EqData +deriving instance Typeable OrdData #endif -- List is isomorphic to [] @@ -57,7 +60,11 @@ | End deriving (Show, Eq, Ord) +data Data = Data deriving (Show) +data EqData = EqData deriving (Show, Eq) +data OrdData = OrdData deriving (Show, Eq, Ord) + -- Dummy undefined values -- ls :: a -> List a @@ -107,15 +114,26 @@ deriveListable ''Dict +deriveListable ''Data +deriveListable ''EqData +deriveListable ''OrdData + deriveGeneralizable ''List {- -- derivation: instance (Generalizable a) => Generalizable (List a) where + name _ = "xs" 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 + instances xs = this xs + $ (let Cons y ys = Cons undefined undefined -: xs + in instances y . instances ys) + +-- It may seem like its possible to derive just: +--instances xs = this xs +-- $ instances (argTy1of1 xs) +-- However that will restrain us from recursing into non argument types that +-- need to be present (cf. the Mutual & Shared types). -} deriveGeneralizable ''Perhaps @@ -123,8 +141,7 @@ 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) + instances px = ... -} deriveGeneralizable ''Ship @@ -132,12 +149,10 @@ 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) + instances s = ... -} --- deriveGeneralizable ''Arrangement -- TODO: make this work +deriveGeneralizable ''Arrangement deriveGeneralizable ''NonEmptyList @@ -149,7 +164,11 @@ deriveGeneralizable ''Dict +deriveGeneralizable ''Data +deriveGeneralizable ''EqData +deriveGeneralizable ''OrdData + main :: IO () main = mainTest tests 2160 @@ -157,36 +176,45 @@ 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 + , generalizableOK n (ls bool) + , generalizableOK n (perhaps int) + , generalizableOK n (ship int char) + , generalizableOK n (arrangement) + , generalizableOK n (mutual bool) + , generalizableOK n (shared int) + , generalizableOK n (tree bool) + , generalizableOK n (leafy int) + , generalizableOK n (dict bool int) + , generalizableOK n EqData + , generalizableOK n OrdData -idExprEval :: (Eq a, Generalizable a) => a -> Bool -idExprEval x = eval (error "idExprEval: could not eval") (expr x) == x + , int `instancesSubset` ls int + , not $ bool `instancesSubset` ls int + , () `instancesSubset` perhaps () + , not $ () `instancesSubset` perhaps int + , () `bgSubset` perhaps int -- () has no background + , char `instancesSubset` ship char int + , int `instancesSubset` ship char int + , not $ bool `instancesSubset` ship char int + , int `instancesSubset` mutual int + , int `instancesSubset` shared int + , shared int `instancesSubset` mutual int + , mutual () `instancesSubset` shared () + , bool `instancesSubset` tree bool + , int `instancesSubset` leafy int + , int `instancesSubset` dict int bool + , bool `instancesSubset` dict int bool + , bool `instancesSubset` dict int (perhaps (ship char bool)) + , shared (ship (ls char) bool) + `instancesSubset` dict int (perhaps (mutual (ship (ls char) bool))) -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 + , backgroundOf Data =$ sort $= [] + , backgroundOf EqData =$ sort $= [ constant "==" $ (==) -:> EqData + , constant "/=" $ (/=) -:> EqData + ] + , backgroundOf OrdData =$ sort $= [ constant "==" $ (==) -:> OrdData + , constant "/=" $ (/=) -:> OrdData + , constant "<=" $ (<=) -:> OrdData + , constant "<" $ (<) -:> OrdData + ] + ] diff --git a/tests/test-extrapolate.hs b/tests/test-extrapolate.hs --- a/tests/test-extrapolate.hs +++ b/tests/test-extrapolate.hs @@ -34,59 +34,43 @@ , 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 $ \x -> show (expr x) == show (x :: ((),Maybe Int,[Bool])) + ++ " :: ((),(Maybe Int),[Bool])" - , 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) + -- Generalizable instance properties + , generalizableOK n () + , generalizableOK n int + , generalizableOK n integer + , generalizableOK n bool + , generalizableOK n char + , generalizableOK n ordering + , generalizableOK 9 [()] + , generalizableOK n [int] + , generalizableOK n [integer] + , generalizableOK n [bool] + , generalizableOK n [char] + , generalizableOK n [ordering] + , generalizableOK n (mayb ()) + , generalizableOK n (mayb int) + , generalizableOK n (mayb integer) + , generalizableOK n (mayb bool) + , generalizableOK n (mayb char) + , generalizableOK n (eith () int) + , generalizableOK n (eith integer bool) + , generalizableOK n (int,bool) + , generalizableOK n ((),integer) + , generalizableOK n ((),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) +--, generalizableOK n (int,(),bool,integer) +--, generalizableOK n (int,(),bool,integer,char) +--, generalizableOK n (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 -:> ((),(),(),(),(),(),(),(),(),(),(),()) - +--, generalizableOK n ((),(),(),(),(),(),()) +--, generalizableOK n ((),(),(),(),(),(),(),()) +--, generalizableOK n ((),(),(),(),(),(),(),(),()) +--, generalizableOK n ((),(),(),(),(),(),(),(),(),()) +--, generalizableOK n ((),(),(),(),(),(),(),(),(),(),()) +--, generalizableOK n ((),(),(),(),(),(),(),(),(),(),(),()) -- Silly test, as it basically replicates the actual implementation: , backgroundOf int =$ sort $= [ constant "==" $ (==) -:> int @@ -98,39 +82,26 @@ -- 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) + , listBackgroundOK [(mayb (),integer,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) - ] + , maybeBackgroundOK [(int,bool,[mayb (char,())])] -idExprEval :: (Eq a, Generalizable a) => a -> Bool -idExprEval x = eval (error "idExprEval: could not eval") (expr x) == x + , int `instancesSubset` [mayb [int]] + , bool `instancesSubset` ((),bool,char) + , [mayb ((),char)] `instancesSubset` [(int,(char,[mayb ((),char)]),bool)] + , not $ bool `instancesSubset` [mayb [int]] + , not $ bool `bgSubset` [mayb [int]] + , not $ bool `sameNamesIn` [mayb [int]] + , not $ bool `sameTiersIn` [mayb [int]] + , not $ mayb int `instancesSubset` [mayb [int]] + , not $ mayb int `bgSubset` [mayb [int]] + , not $ mayb int `sameNamesIn` [mayb [int]] + , not $ mayb int `sameTiersIn` [mayb [int]] + ] listBackgroundOK :: Generalizable a => a -> Bool listBackgroundOK x = backgroundOf [x] =$ sort $= backgroundListOf x