ixset 1.0.7 → 1.1.1.2
raw patch · 5 files changed
Files
- ixset.cabal +24/−20
- src/Data/IxSet.hs +19/−6
- src/Data/IxSet/Ix.hs +4/−4
- tests/Data/IxSet/Tests.hs +279/−0
- tests/Test.hs +14/−0
ixset.cabal view
@@ -1,5 +1,5 @@ Name: ixset-Version: 1.0.7+Version: 1.1.1.2 Synopsis: Efficient relational queries on Haskell sets. Description: Create and query sets that are indexed by multiple indices.@@ -10,38 +10,42 @@ 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.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.2 source-repository head type: git location: https://github.com/Happstack/ixset.git -flag base4- Library- if flag(base4)- Build-Depends: base >=4 && < 5, syb- else- Build-Depends: base < 4-- if impl(ghc >= 6.12.1)- Build-Depends: syb-with-class >= 0.6.1- else- Build-Depends: syb-with-class < 0.6.1+ Build-Depends: base >=4.7 && < 5, syb + if !impl(ghc >= 8.0)+ build-depends: semigroups >= 0.18 && < 0.21 - Build-Depends: containers,+ Build-Depends: containers >=0.5.5.1, safecopy,- template-haskell+ template-haskell,+ syb-with-class >= 0.6.1 hs-source-dirs: src Exposed-modules: Data.IxSet Data.IxSet.Ix - if impl(ghc >= 6.12)- ghc-options: -Wall -fno-warn-unused-do-bind- else- ghc-options: -Wall+ ghc-options: -Wall -fno-warn-unused-do-bind+ 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
src/Data/IxSet.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE UndecidableInstances, OverlappingInstances, FlexibleInstances,+{-# LANGUAGE UndecidableInstances, OverlappingInstances, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, RankNTypes, FunctionalDependencies, DeriveDataTypeable, GADTs, CPP, ScopedTypeVariables #-}@@ -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@@ -365,8 +367,13 @@ getCalType (ForallT _names _ t') = getCalType t' getCalType (AppT (AppT ArrowT _) t') = t' getCalType t' = error ("Unexpected type in getCalType: " ++ pprint t')+#if MIN_VERSION_template_haskell(2,17,0)+ binders' = map (fmap (\() -> SpecifiedSpec)) (binders :: [TyVarBndr ()])+#else+ binders' = binders+#endif mkEntryPoint n = (conE 'Ix) `appE`- (sigE (varE 'Map.empty) (forallT binders (return context) $+ (sigE (varE 'Map.empty) (forallT binders' (return context) $ appT (appT (conT ''Map) (conT n)) (appT (conT ''Set) typeCon))) `appE` (varE 'flattenWithCalcs `appE` varE calName)@@ -391,7 +398,11 @@ isSigD (SigD _ _) = True isSigD _ = False -#if MIN_VERSION_template_haskell(2,4,0)+#if MIN_VERSION_template_haskell(2,17,0)+tyVarBndrToName :: TyVarBndr a -> Name+tyVarBndrToName (PlainTV nm _) = nm+tyVarBndrToName (KindedTV nm _ _) = nm+#elif MIN_VERSION_template_haskell(2,4,0) tyVarBndrToName :: TyVarBndr -> Name tyVarBndrToName (PlainTV nm) = nm tyVarBndrToName (KindedTV nm _) = nm@@ -793,7 +804,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
src/Data/IxSet/Ix.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE UndecidableInstances, OverlappingInstances, FlexibleInstances,+{-# LANGUAGE UndecidableInstances, OverlappingInstances, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, PolymorphicComponents, DeriveDataTypeable,ExistentialQuantification #-} @@ -23,7 +23,7 @@ import qualified Data.Generics.SYB.WithClass.Basics as SYBWC import Data.List (foldl') import Data.Map (Map)-import qualified Data.Map as Map+import qualified Data.Map.Strict as Map import Data.Set (Set) import qualified Data.Set as Set @@ -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@@ -66,7 +66,7 @@ -- 'Map', then a new 'Set' is added transparently. insert :: (Ord a, Ord k) => k -> a -> Map k (Set a) -> Map k (Set a)-insert k v index = Map.insertWith' Set.union k (Set.singleton v) index+insert k v index = Map.insertWith Set.union k (Set.singleton v) index -- | Helper function to 'insert' a list of elements into a set. insertList :: (Ord a, Ord k)
+ tests/Data/IxSet/Tests.hs view
@@ -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
+ tests/Test.hs view
@@ -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 ()