extrapolate 0.1.0 → 0.2.0

raw patch · 13 files changed

+402/−270 lines, 13 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• README.md +96/−9
• TODO.md +14/−12
• extrapolate.cabal +3/−3
• src/Test/Extrapolate.hs +8/−9
• src/Test/Extrapolate/Basic.hs +2/−1
• src/Test/Extrapolate/Core.hs +103/−66
• src/Test/Extrapolate/Derive.hs +22/−16
• src/Test/Extrapolate/Exprs.hs +5/−0
• src/Test/Extrapolate/IO.hs +10/−36
• src/Test/Extrapolate/TypeBinding.hs +4/−0
• src/Test/Extrapolate/Utils.hs +18/−0
• tests/test-derive.hs +69/−41
• tests/test-extrapolate.hs +48/−77

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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]

@@ -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

@@ -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

@@ -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

@@ -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 

@@ -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"

@@ -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<N>+  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+                                    ]+  ]

@@ -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