diff --git a/ixset.cabal b/ixset.cabal --- a/ixset.cabal +++ b/ixset.cabal @@ -1,5 +1,5 @@ Name: ixset -Version: 1.0.7 +Version: 1.1 Synopsis: Efficient relational queries on Haskell sets. Description: Create and query sets that are indexed by multiple indices. @@ -10,8 +10,8 @@ homepage: http://happstack.com Category: Data Structures Build-Type: Simple -Cabal-Version: >= 1.8 -tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 +Cabal-Version: >= 1.10 +tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.2 source-repository head type: git @@ -25,6 +25,8 @@ else Build-Depends: base < 4 + if impl(ghc < 8.4) + build-depends: semigroups == 0.18.* if impl(ghc >= 6.12.1) Build-Depends: syb-with-class >= 0.6.1 else @@ -44,4 +46,18 @@ ghc-options: -Wall -fno-warn-unused-do-bind else ghc-options: -Wall + default-language: Haskell2010 +Test-Suite test-ixset + Default-Language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Test.hs + other-modules: Data.IxSet.Tests + hs-source-dirs: tests + build-depends: base, + Cabal >= 1.10, + containers, + HUnit, + ixset, + QuickCheck, + random diff --git a/src/Data/IxSet.hs b/src/Data/IxSet.hs --- a/src/Data/IxSet.hs +++ b/src/Data/IxSet.hs @@ -135,6 +135,8 @@ (@>=<=), (@+), (@*), + getOrd, + getOrd2, getEQ, getLT, getGT, @@ -171,7 +173,7 @@ import qualified Data.Set as Set import Data.Typeable (Typeable, cast, typeOf) import Language.Haskell.TH as TH - +import Data.Semigroup ------------------------------------------------- -- Type proxies @@ -258,7 +260,7 @@ , SYBWC.Data ctx [a] , SYBWC.Sat (ctx (IxSet a)) , SYBWC.Sat (ctx [a]) - , SYBWC.Typeable1 IxSet + , SYBWC.Typeable IxSet , Indexable a , Data a , Ord a @@ -793,7 +795,9 @@ * can we index on xpath rather than just type? --} - +instance (Indexable a, Typeable a, Ord a) => Semigroup (IxSet a) where + (<>) = union + instance (Indexable a, Typeable a, Ord a) => Monoid (IxSet a) where mempty = empty mappend = union diff --git a/src/Data/IxSet/Ix.hs b/src/Data/IxSet/Ix.hs --- a/src/Data/IxSet/Ix.hs +++ b/src/Data/IxSet/Ix.hs @@ -52,7 +52,7 @@ ixDataType :: SYBWC.DataType ixDataType = SYBWC.mkDataType "Ix" [ixConstr] -instance (SYBWC.Typeable1 Ix, SYBWC.Data ctx a, SYBWC.Sat (ctx (Ix a))) +instance (SYBWC.Typeable Ix, SYBWC.Data ctx a, SYBWC.Sat (ctx (Ix a))) => SYBWC.Data ctx (Ix a) where gfoldl _ _ _ _ = error "gfoldl Ix" :: w (Ix a) toConstr _ (Ix _ _) = ixConstr diff --git a/tests/Data/IxSet/Tests.hs b/tests/Data/IxSet/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Data/IxSet/Tests.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, OverlappingInstances, UndecidableInstances, TemplateHaskell, KindSignatures #-} + +-- Check that the SYBWC Data instance for IxSet works, by testing +-- that going to and from XML works. + +module Data.IxSet.Tests where + +import Control.Monad +import Control.Exception as E +import Data.Data as Data +import Data.IxSet as IxSet +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set +import System.Random +import Test.HUnit (Test,(~:),(@=?), test) +import qualified Test.HUnit as HU +import Test.QuickCheck +import qualified Test.QuickCheck as QC + +qccheck :: QC.Testable a => QC.Args -> a -> HU.Test +qccheck args prop = + HU.TestCase $ + do result <- QC.quickCheckWithResult args prop + case result of + (QC.Success {}) -> return () + (QC.GaveUp {}) -> + let ntest = QC.numTests result + in HU.assertFailure $ "Arguments exhausted after" ++ show ntest ++ (if ntest == 1 then " test." else " tests.") + (QC.Failure {}) -> HU.assertFailure (QC.reason result) + (QC.NoExpectedFailure {}) -> HU.assertFailure $ "No Expected Failure" + +qctest :: QC.Testable a => a -> HU.Test +qctest = qccheck QC.stdArgs + + +data Foo + = Foo String Int + deriving (Eq, Ord, Show, Data, Typeable) + +data FooX + = Foo1 String Int + | Foo2 Int + deriving (Eq, Ord, Show, Data, Typeable) + +data NoIdxFoo + = NoIdxFoo Int + deriving (Eq, Ord, Show, Data, Typeable) + +data BadlyIndexed + = BadlyIndexed Int + deriving (Eq, Ord, Show, Data, Typeable) + +data MultiIndex + = MultiIndex String Int Integer (Maybe Int) (Either Bool Char) + | MultiIndexSubset Int Bool String + deriving (Eq, Ord, Show, Data, Typeable) + +data Triple + = Triple Int Int Int + deriving (Eq, Ord, Show, Data, Typeable) + +data S + = S String + deriving (Eq, Ord, Show, Data, Typeable) + +data G a b + = G a b + deriving (Eq, Ord, Show, Data, Typeable) + + +$(inferIxSet "FooXs" ''FooX 'noCalcs [''Int, + ''String + ]) + +$(inferIxSet "BadlyIndexeds" ''BadlyIndexed 'noCalcs [''String]) +$(inferIxSet "MultiIndexed" ''MultiIndex 'noCalcs [''String, ''Int, ''Integer, ''Bool, ''Char]) +$(inferIxSet "Triples" ''Triple 'noCalcs [''Int]) +$(inferIxSet "Gs" ''G 'noCalcs [''Int]) + +fooCalcs (Foo s _) = s ++ "bar" +$(inferIxSet "Foos" ''Foo 'fooCalcs [''String, ''Int]) + + +instance Indexable S where + empty = ixSet [ ixFun (\(S x) -> [length x]) + ] + -- calcs _ = () + +ixSetCheckMethodsOnDefault :: Test +ixSetCheckMethodsOnDefault = "ixSetCheckMethodsOnDefault" ~: test + [ "size is zero" ~: 0 @=? + size (IxSet.empty :: Foos) + , "getOne returns Nothing" ~: + Nothing @=? getOne (IxSet.empty :: Foos) + , "getOneOr returns default" ~: + Foo1 "" 44 @=? getOneOr (Foo1 "" 44) IxSet.empty + , "toList returns []" ~: + [] @=? toList (IxSet.empty :: Foos) + ] + +foox_a :: FooX +foox_a = Foo1 "abc" 10 +foox_b :: FooX +foox_b = Foo1 "abc" 20 +foox_c :: FooX +foox_c = Foo2 10 +foox_d :: FooX +foox_d = Foo2 20 +foox_e :: FooX +foox_e = Foo2 30 + +foox_set_abc :: FooXs +foox_set_abc = insert foox_a $ insert foox_b $ insert foox_c $ IxSet.empty +foox_set_cde :: FooXs +foox_set_cde = insert foox_e $ insert foox_d $ insert foox_c $ IxSet.empty + +ixSetCheckSetMethods :: Test +ixSetCheckSetMethods = "ixSetCheckSetMethods" ~: test + [ "size abc is 3" ~: 3 @=? + size foox_set_abc + , "size cde is 3" ~: 3 @=? + size foox_set_cde + , "getOne returns Nothing" ~: + Nothing @=? getOne foox_set_abc + , "getOneOr returns default" ~: + Foo1 "" 44 @=? getOneOr (Foo1 "" 44) foox_set_abc + , "toList returns 3 element list" ~: + 3 @=? length (toList foox_set_abc) + ] + +isError :: a -> IO Bool +isError x = (x `seq` return False) `E.catch` \(ErrorCall _) -> return True + +badIndexSafeguard :: Test +badIndexSafeguard = "badIndexSafeguard" ~: test + [ "check if there is error when no first index on value" ~: + isError (size $ insert (BadlyIndexed 123) empty) + , "check if indexing with missing index" ~: + isError (getOne (foox_set_cde @= True)) + ] + +testTriple :: Test +testTriple = "testTriple" ~: test + [ "check if we can find element" ~: + 1 @=? size ((insert (Triple 1 2 3) empty) + @= (1::Int) @= (2::Int)) + ] + + +instance Arbitrary Foo where + arbitrary = liftM2 Foo arbitrary arbitrary + +instance (Arbitrary a,Data.Data a, Ord a, Indexable a) => + Arbitrary (IxSet a) where + arbitrary = liftM fromList arbitrary + +prop_sizeEqToListLength :: Foos -> Bool +prop_sizeEqToListLength ixset = size ixset == length (toList ixset) + +prop_union :: Foos -> Foos -> Bool +prop_union ixset1 ixset2 = + toSet (ixset1 `union` ixset2) == toSet ixset1 `Set.union` toSet ixset2 + +prop_intersection :: Foos -> Foos -> Bool +prop_intersection ixset1 ixset2 = + toSet (ixset1 `intersection` ixset2) == + toSet ixset1 `Set.intersection` toSet ixset2 + +prop_opers :: Foos -> Int -> Bool +prop_opers ixset intidx = + and [ (lt `union` eq) == lteq + , (gt `union` eq) == gteq + -- this works for Foo as an Int field is in every Foo value + , (gt `union` eq `union` lt) == ixset +-- , (neq `intersection` eq) == empty + ] + where +-- neq = ixset @/= intidx + eq = ixset @= intidx + lt = ixset @< intidx + gt = ixset @> intidx + lteq = ixset @<= intidx + gteq = ixset @>= intidx + +prop_sureelem :: Foos -> Foo -> Bool +prop_sureelem ixset foo@(Foo string intidx) = + not (IxSet.null eq) && + not (IxSet.null lteq) && + not (IxSet.null gteq) + where + ixset' = insert foo ixset + eq = ixset' @= intidx + lteq = ixset' @<= intidx + gteq = ixset' @>= intidx + +prop_ranges :: Foos -> Int -> Int -> Bool +prop_ranges ixset intidx1 intidx2 = + ((ixset @>< (intidx1,intidx2)) == (gt1 &&& lt2)) && + ((ixset @>=< (intidx1,intidx2)) == ((gt1 ||| eq1) &&& lt2)) && + ((ixset @><= (intidx1,intidx2)) == (gt1 &&& (lt2 ||| eq2))) && + ((ixset @>=<= (intidx1,intidx2)) == ((gt1 ||| eq1) &&& (lt2 ||| eq2))) + where + eq1 = ixset @= intidx1 + lt1 = ixset @< intidx1 + gt1 = ixset @> intidx1 + eq2 = ixset @= intidx2 + lt2 = ixset @< intidx2 + gt2 = ixset @> intidx2 + + +prop_any :: Foos -> [Int] -> Bool +prop_any ixset idxs = + (ixset @+ idxs) == foldr union empty (map ((@=) ixset) idxs) + +prop_all :: Foos -> [Int] -> Bool +prop_all ixset idxs = + (ixset @* idxs) == foldr intersection ixset (map ((@=) ixset) idxs) + +funSet :: IxSet S +funSet = IxSet.fromList [S "", S "abc", S "def", S "abcde"] + +funIndexes :: Test +funIndexes = "funIndexes" ~: test + [ "has zero length element" ~: 1 @=? + size (funSet @= (0 :: Int)) + , "has two lengh 3 elements" ~: 2 @=? + size (funSet @= (3 :: Int)) + , "has three lengh [3;7] elements" ~: 3 @=? + size (funSet @>=<= (3 :: Int, 7 :: Int)) + ] + +allTests :: [Test] +allTests = + [ ixSetCheckMethodsOnDefault + , ixSetCheckSetMethods + , badIndexSafeguard + , test (True @=? findElement 1 1) + , testTriple + , funIndexes + , "prop_sizeEqToListLength" ~: qctest prop_sizeEqToListLength + , "prop_union" ~: qctest prop_union + , "prop_union" ~: qctest prop_intersection + , "prop_opers" ~: qctest prop_opers + , "prop_sureelem" ~: qctest prop_sureelem + , "prop_ranges" ~: qctest prop_ranges + , "prop_any" ~: qctest prop_any + , "prop_all" ~: qctest prop_all + ] + + + +bigSet :: Int -> MultiIndexed +bigSet n = fromList $ + [ MultiIndex string int integer maybe_int either_bool_char | + string <- ["abc", "def", "ghi", "jkl"], + int <- [1..n], + integer <- [10000..10010], + maybe_int <- [Nothing, Just 5, Just 6], + either_bool_char <- [Left True, Left False, Right 'A', Right 'B']] ++ + [ MultiIndexSubset int bool string | + string <- ["abc", "def", "ghi"], + int <- [1..n], + bool <- [True, False]] + +findElementX :: MultiIndexed -> Int -> Bool +findElementX set n = isJust $ getOne (set @+ ["abc","def","ghi"] + @>=<= (10000 :: Integer,10010 :: Integer) + @= (True :: Bool) + @= (n `div` n) + @= "abc" + @= (10000 :: Integer) + @= (5 :: Int)) + +findElement :: Int -> Int -> Bool +findElement n m = all id ([findElementX set k | k <- [1..n]]) + where set = bigSet m diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -0,0 +1,14 @@ +module Main where + +import Data.IxSet.Tests (allTests) +import Prelude hiding (catch) +import Test.HUnit (failures, runTestTT) +import qualified Test.HUnit as HUnit +import System.Exit (exitFailure) +import qualified System.Exit as Exit +import Test.HUnit +import Test.HUnit.Text + +main = do + count <- HUnit.runTestTT (TestList allTests) + if HUnit.failures count > 0 then Exit.exitFailure else return ()