diff --git a/speculate.cabal b/speculate.cabal --- a/speculate.cabal +++ b/speculate.cabal @@ -1,5 +1,5 @@ name: speculate -version: 0.2.8 +version: 0.2.9 synopsis: discovery of properties about Haskell functions description: Speculate automatically discovers laws about Haskell functions. @@ -31,7 +31,7 @@ source-repository this type: git location: https://github.com/rudymatela/speculate - tag: v0.2.8 + tag: v0.2.9 library diff --git a/src/Test/Speculate/Expr/Equate.hs b/src/Test/Speculate/Expr/Equate.hs --- a/src/Test/Speculate/Expr/Equate.hs +++ b/src/Test/Speculate/Expr/Equate.hs @@ -17,6 +17,7 @@ ( equation, unEquation, isEquation, uselessEquation, usefulEquation , phonyEquation + , inequality , comparisonLT, comparisonLE, unComparison , implication, unImplication, usefulImplication @@ -61,6 +62,11 @@ usefulEquation :: Expr -> Bool usefulEquation = uncurry (/=) . unEquation + +inequality :: Instances -> Expr -> Expr -> Maybe Expr +inequality ti e1 e2 = do + e <- iqE ti (typ e1) + e :$ e1 $$ e2 comparisonLT :: Instances -> Expr -> Expr -> Maybe Expr comparisonLT ti e1 e2 = do diff --git a/src/Test/Speculate/Expr/Instance.hs b/src/Test/Speculate/Expr/Instance.hs --- a/src/Test/Speculate/Expr/Instance.hs +++ b/src/Test/Speculate/Expr/Instance.hs @@ -25,7 +25,7 @@ , instanceType , findInfo , names - , eqE, isEq, isEqE + , eqE, iqE, isEq, isEqE , leE, ltE, isOrd, isOrdE , isEqOrd, isEqOrdE , tiersE, isListable @@ -133,7 +133,8 @@ eqWith :: (Typeable a, Eq a) => (a -> a -> Bool) -> Instances eqWith (==) = [ Instance "Eq" (typeOf $ arg (==)) - [constant "==" $ errorToFalse .: (==)] ] + [ constant "==" $ errorToFalse .: (==) + , constant "/=" $ (errorToFalse . not) .: (==)] ] where arg :: (a -> b) -> a arg _ = undefined @@ -198,8 +199,14 @@ eqE :: Instances -> TypeRep -> Maybe Expr eqE ti t = findInfo m ti where - m (Instance "Eq" t' [eq]) | t == t' = Just eq - m _ = Nothing + m (Instance "Eq" t' [eq,_]) | t == t' = Just eq + m _ = Nothing + +iqE :: Instances -> TypeRep -> Maybe Expr +iqE ti t = findInfo m ti + where + m (Instance "Eq" t' [_,iq]) | t == t' = Just iq + m _ = Nothing ltE :: Instances -> TypeRep -> Maybe Expr ltE ti t = findInfo m ti diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -74,7 +74,7 @@ , true, false , pp, qq, rr , not', (-&&-), (-||-), (-==>-) - , (-==-), (-<=-), (-<-) + , (-==-), (-/=-), (-<=-), (-<-) , odd', even' -- ** Characters @@ -489,6 +489,12 @@ fromMaybe (error $ "(-==-): cannot equate " ++ show e1 ++ " and " ++ show e2) (equation preludeInstances e1 e2) infix 4 -==- + +(-/=-) :: Expr -> Expr -> Expr +e1 -/=- e2 = + fromMaybe (error $ "(-/=-): cannot inequate " ++ show e1 ++ " and " ++ show e2) + (inequality preludeInstances e1 e2) +infix 4 -/=- (-<=-) :: Expr -> Expr -> Expr e1 -<=- e2 = diff --git a/tests/test-eval.hs b/tests/test-eval.hs --- a/tests/test-eval.hs +++ b/tests/test-eval.hs @@ -43,6 +43,11 @@ , trueBinds preludeInstances 500 (xx -==- zero) == [[("x",zero)]] , trueBinds preludeInstances 500 (xx -==- one) == [[("x",one)]] , trueBinds preludeInstances 500 ((xx -==- one) -&&- (yy -==- zero)) == [[("x",one),("y",zero)]] + + , holds n $ ordOK -:> int + , holds n $ ordOK -:> () + , holds n $ ordOK -:> bool + , holds n $ ordOK -:> [int] ] where n' = n `div` 50 @@ -51,3 +56,18 @@ x =/= y = not (x === y) infix 4 =/= x //= y = inequal preludeInstances 500 x y + +(*==*), (*/=*), (*<=*), (*<*) :: (Show a, Typeable a) => a -> a -> Bool +x *==* y = eval undefined $ showConstant x -==- showConstant y +x */=* y = eval undefined $ showConstant x -/=- showConstant y +x *<=* y = eval undefined $ showConstant x -<=- showConstant y +x *<* y = eval undefined $ showConstant x -<- showConstant y + +eqOK :: (Eq a, Show a, Typeable a) => a -> a -> Bool +eqOK x y = (x *==* y) == (x == y) + && (x */=* y) == (x /= y) + +ordOK :: (Eq a, Ord a, Show a, Typeable a) => a -> a -> Bool +ordOK x y = eqOK x y + && (x *<=* y) == (x <= y) + && (x *<* y) == (x < y) diff --git a/tests/test-expr.hs b/tests/test-expr.hs --- a/tests/test-expr.hs +++ b/tests/test-expr.hs @@ -74,6 +74,10 @@ , absE < timesE , aa < ordE , ordE < timesE + , constant "id" (id -:> int) < constant "id" (id -:> [int]) + , constant "id" (id -:> [int]) < constant "id" (id -:> [[int]]) + , constant "id" (id -:> int) < constant "sum" (sum -:> [int]) + , constant "id" (id -:> int) < constant "(:[])" ((:[]) -:> int) -- precedent types , pp < xx @@ -174,28 +178,6 @@ , xx < yy , zero < one , xx < zero - -{- -- commenting out as those tests are causing more harm than good. - -- If those two ever fail, it is because the instance for Ord TypeRep in - -- Data.Typeable has changed. I do rely on this for a "nice" knuth-bendix - -- order (by prefering less arity). If this ever changes, I will have to - -- explicitly compare type arity on Ord Expr. - -- (update: haha! It has changed from before, and twice, and thrice!) - -- TODO: fix order under GHC <= 7.8 -#if __GLASGOW_HASKELL__ < 706 - , typeOf ((+) :: Int -> Int -> Int) > typeOf (abs :: Int -> Int) - , typeOf (abs :: Int -> Int) < typeOf (0 :: Int) -#elif __GLASGOW_HASKELL__ < 800 - , typeOf ((+) :: Int -> Int -> Int) < typeOf (abs :: Int -> Int) - , typeOf (abs :: Int -> Int) < typeOf (0 :: Int) -#elif __GLASGOW_HASKELL__ < 802 - , typeOf ((+) :: Int -> Int -> Int) > typeOf (abs :: Int -> Int) - , typeOf (abs :: Int -> Int) > typeOf (0 :: Int) -#else - , typeOf ((+) :: Int -> Int -> Int) < typeOf (abs :: Int -> Int) - , typeOf (abs :: Int -> Int) > typeOf (0 :: Int) -#endif --} , holds n $ \(IntE e1) (IntE e2) -> isTuple (pair e1 e2) && unfoldTuple (pair e1 e2) == [e1,e2]