diff --git a/ixset-typed.cabal b/ixset-typed.cabal --- a/ixset-typed.cabal +++ b/ixset-typed.cabal @@ -1,5 +1,5 @@ name: ixset-typed -version: 0.1.4 +version: 0.2 synopsis: Efficient relational queries on Haskell sets. description: This Haskell package provides a data structure of sets that are indexed @@ -30,10 +30,11 @@ location: https://github.com/kosmikus/ixset-typed.git library - build-depends: base >= 4.6 && < 5, - syb >= 0.4 && < 1, - containers >= 0.5 && < 1, - safecopy >= 0.8 && < 1, + build-depends: base >= 4.6 && < 5, + containers >= 0.5 && < 1, + deepseq >= 1.3 && < 2, + safecopy >= 0.8 && < 1, + syb >= 0.4 && < 1, template-haskell >= 2.8 && < 3 hs-source-dirs: src @@ -43,5 +44,23 @@ ghc-options: -Wall -fno-warn-unused-do-bind ghc-prof-options: -auto-all + + default-language: Haskell2010 + +test-suite test-ixset-typed + type: exitcode-stdio-1.0 + build-depends: ixset-typed, + base >= 4.6 && < 5, + containers >= 0.5 && < 1, + HUnit, + QuickCheck, + tasty, + tasty-hunit, + tasty-quickcheck + hs-source-dirs: tests + main-is: TestIxSetTyped.hs + other-modules: Data.IxSet.Typed.Tests + + ghc-options: -Wall default-language: Haskell2010 diff --git a/src/Data/IxSet/Typed.hs b/src/Data/IxSet/Typed.hs --- a/src/Data/IxSet/Typed.hs +++ b/src/Data/IxSet/Typed.hs @@ -26,7 +26,7 @@ > deriving (Show, Eq, Ord, Data, Typeable) 1. Decide what parts of your type you want indexed and make your type -an instance of 'Indexable'. Use 'ixFun' and 'ixGen' to build indexes: +an instance of 'Indexable'. Use 'ixFun' and 'ixGen' to build indices: > type EntryIxs = '[Author, Id, Updated, Test] > type IxEntry = IxSet EntryIxs Entry @@ -39,7 +39,7 @@ > (ixGen (Proxy :: Proxy Test)) -- bogus index The use of 'ixGen' requires the 'Data' and 'Typeable' instances above. - You can build indexes manually using 'ixFun'. You can also use the + You can build indices manually using 'ixFun'. You can also use the Template Haskell function 'inferIxSet' to generate an 'Indexable' instance automatically. @@ -187,6 +187,9 @@ import Prelude hiding (null) import Control.Arrow (first, second) +import Control.DeepSeq +import Data.Foldable (Foldable) +import qualified Data.Foldable as Fold import Data.Generics (Data, gmapQ) -- import qualified Data.Generics.SYB.WithClass.Basics as SYBWC import qualified Data.IxSet.Typed.Ix as Ix @@ -203,8 +206,9 @@ import Language.Haskell.TH as TH import GHC.Exts (Constraint) - --- the core datatypes +-------------------------------------------------------------------------- +-- The main 'IxSet' datatype. +-------------------------------------------------------------------------- -- | Set with associated indices. -- @@ -217,11 +221,26 @@ Nil :: IxList '[] a (:::) :: Ix ix a -> IxList ixs a -> IxList (ix ': ixs) a +infixr 5 ::: + +-- TODO: +-- +-- We cannot currently derive Typeable for 'IxSet': +-- +-- * In ghc-7.6, Typeable isn't supported for non-* kinds. +-- * In ghc-7.8, see bug #8950. We can work around this, but I rather +-- would wait for a proper fix. + -- deriving instance Data (IxSet ixs a) -- deriving instance Typeable IxSet -infixr 5 ::: +-------------------------------------------------------------------------- +-- Type-level tools for dealing with indexed sets. +-- +-- These are partially internal. TODO: Move to different module? +-------------------------------------------------------------------------- + -- | The constraint @All c xs@ says the @c@ has to hold for all -- elements in the type-level list @xs@. -- @@ -237,6 +256,49 @@ type instance All c '[] = () type instance All c (x ': xs) = (c x, All c xs) +-- | Associate indices with a given type. The constraint +-- @'Indexable' ixs a@ says that we know how to build index sets +-- of type @'IxSet' ixs a@. +-- +-- In order to use an 'IxSet' on a particular type, you have to +-- make it an instance of 'Indexable' yourself. There are no +-- predefined instances of 'IxSet'. +-- +class (All Ord ixs, Ord a) => Indexable ixs a where + + -- | Define what an empty 'IxSet' for this particular type should look + -- like. It should have all necessary indices. + -- + -- Use the 'mkEmpty' function to create the set and add indices + -- with 'ixFun' (or 'ixGen'). + empty :: IxSet ixs a + +-- | Constraint for membership in the type-level list. Says that 'ix' +-- is contained in the index list 'ixs'. +class Ord ix => IsIndexOf (ix :: *) (ixs :: [*]) where + + -- | Provide access to the selected index in the list. + access :: IxList ixs a -> Ix ix a + + -- | Map over the index list, treating the selected different + -- from the rest. + mapAt :: (All Ord ixs) + => (Ix ix a -> Ix ix a) + -- ^ what to do with the selected index + -> (forall ix'. Ord ix' => Ix ix' a -> Ix ix' a) + -- ^ what to do with the other indices + -> IxList ixs a -> IxList ixs a + +instance Ord ix => IsIndexOf ix (ix ': ixs) where + access (x ::: _xs) = x + mapAt fh ft (x ::: xs) = fh x ::: mapIxList ft xs + +instance IsIndexOf ix ixs => IsIndexOf ix (ix' ': ixs) where + access (_x ::: xs) = access xs + mapAt fh ft (x ::: xs) = ft x ::: mapAt fh ft xs + +-- | Return the length of an index list. +-- -- TODO: Could be statically unrolled. lengthIxList :: forall ixs a. IxList ixs a -> Int lengthIxList = go 0 @@ -245,41 +307,106 @@ go !acc Nil = acc go !acc (_ ::: xs) = go (acc + 1) xs -ixListToList :: All Ord ixs => (forall ix. Ord ix => Ix ix a -> r) -> IxList ixs a -> [r] +-- | Turn an index list into a normal list, given a function that +-- turns an arbitrary index into an element of a fixed type @r@. +ixListToList :: All Ord ixs + => (forall ix. Ord ix => Ix ix a -> r) + -- ^ what to do with each index + -> IxList ixs a -> [r] ixListToList _ Nil = [] ixListToList f (x ::: xs) = f x : ixListToList f xs -mapIxList :: (All Ord ixs) +-- | Map over an index list. +mapIxList :: All Ord ixs => (forall ix. Ord ix => Ix ix a -> Ix ix a) + -- ^ what to do with each index -> IxList ixs a -> IxList ixs a mapIxList _ Nil = Nil mapIxList f (x ::: xs) = f x ::: mapIxList f xs -zipWithIxList :: (All Ord ixs) +-- | Zip two index lists of compatible type. +zipWithIxList :: All Ord ixs => (forall ix. Ord ix => Ix ix a -> Ix ix a -> Ix ix a) + -- ^ how to combine two corresponding indices -> IxList ixs a -> IxList ixs a -> IxList ixs a zipWithIxList _ Nil Nil = Nil zipWithIxList f (x ::: xs) (y ::: ys) = f x y ::: zipWithIxList f xs ys zipWithIxList _ _ _ = error "Data.IxSet.Typed.zipWithIxList: impossible" + -- the line above is actually impossible by the types; it's just there + -- to please avoid the warning resulting from the exhaustiveness check --- Constraint for membership in the type-level list. Says that 'ix' --- is contained in the index list 'ixs'. -class Ord ix => IsIndexOf (ix :: *) (ixs :: [*]) where - access :: IxList ixs a -> Ix ix a - mapAt :: (All Ord ixs) - => (Ix ix a -> Ix ix a) - -> (forall ix'. Ord ix' => Ix ix' a -> Ix ix' a) - -> IxList ixs a -> IxList ixs a +-------------------------------------------------------------------------- +-- Various instances for 'IxSet' +-------------------------------------------------------------------------- -instance Ord ix => IsIndexOf ix (ix ': ixs) where - access (x ::: _xs) = x - mapAt fh ft (x ::: xs) = fh x ::: mapIxList ft xs +instance Indexable ixs a => Eq (IxSet ixs a) where + IxSet a _ == IxSet b _ = a == b -instance IsIndexOf ix ixs => IsIndexOf ix (ix' ': ixs) where - access (_x ::: xs) = access xs - mapAt fh ft (x ::: xs) = ft x ::: mapAt fh ft xs +instance Indexable ixs a => Ord (IxSet ixs a) where + compare (IxSet a _) (IxSet b _) = compare a b --- | Create an 'IxSet' using a set and a number of indexes. If you want to +instance (Indexable ixs a, Show a) => Show (IxSet ixs a) where + showsPrec prec = showsPrec prec . toSet + +instance (Indexable ixs a, Read a) => Read (IxSet ixs a) where + readsPrec n = map (first fromSet) . readsPrec n + +instance (Indexable ixs a, SafeCopy a) => SafeCopy (IxSet ixs a) where + putCopy = contain . safePut . toList + getCopy = contain $ fmap fromList safeGet + +instance (All NFData ixs, NFData a) => NFData (IxList ixs a) where + rnf Nil = () + rnf (x ::: xs) = rnf x `seq` rnf xs + +instance (All NFData ixs, NFData a) => NFData (IxSet ixs a) where + rnf (IxSet a ixs) = rnf a `seq` rnf ixs + +instance Indexable ixs a => Monoid (IxSet ixs a) where + mempty = empty + mappend = union + +instance Foldable (IxSet ixs) where + fold = Fold.fold . toSet + foldMap f = Fold.foldMap f . toSet + foldr f z = Fold.foldr f z . toSet + foldl f z = Fold.foldl f z . toSet + +-- TODO: Do we need SYBWC? +{- +instance ( SYBWC.Data ctx a + , SYBWC.Data ctx [a] + , SYBWC.Sat (ctx (IxSet a)) + , SYBWC.Sat (ctx [a]) + , Indexable a + , Data a + , Ord a + ) + => SYBWC.Data ctx (IxSet a) where + gfoldl _ f z ixset = z fromList `f` toList ixset + toConstr _ (IxSet _) = ixSetConstr + gunfold _ k z c = case SYBWC.constrIndex c of + 1 -> k (z fromList) + _ -> error "IxSet.SYBWC.Data.gunfold unexpected match" + dataTypeOf _ _ = ixSetDataType + +ixSetConstr :: SYBWC.Constr +ixSetConstr = SYBWC.mkConstr ixSetDataType "IxSet" [] SYBWC.Prefix +ixSetDataType :: SYBWC.DataType +ixSetDataType = SYBWC.mkDataType "IxSet" [ixSetConstr] +-} + +-- TODO: Do we need Default? +{- FIXME +instance (Indexable a, Ord a,Data a, Default a) => Default (IxSet a) where + defaultValue = empty +-} + +-------------------------------------------------------------------------- +-- 'IxSet' construction +-------------------------------------------------------------------------- + +-- | Create an 'IxSet' using a set and a number of indices. If you want to -- use this in the 'Indexable' 'empty' method, better use 'mkEmpty' instead. -- -- Note that this function takes a variable number of arguments. @@ -293,8 +420,8 @@ ixSet :: MkIxSet ixs ixs a r => Set a -> r ixSet s = ixSet' (IxSet s) --- | Create an empty 'IxSet' using a number of indexes. Useful in the 'Indexable' --- 'empty' method. Use 'ixFun' and 'ixGen' for the individual indexes. +-- | Create an empty 'IxSet' using a number of indices. Useful in the 'Indexable' +-- 'empty' method. Use 'ixFun' and 'ixGen' for the individual indices. -- -- Note that this function takes a variable number of arguments. -- Here are some example types at which the function can be used: @@ -328,20 +455,19 @@ ixSet' acc ix = ixSet' (\ x -> acc (ix ::: x)) -- | Create a functional index. Provided function should return a list --- of indexes where the value should be found. +-- of indices where the value should be found. -- -- > getIndexes :: Type -> [IndexType] --- > getIndexes value = [...indexes...] +-- > getIndexes value = [...indices...] -- -- > instance Indexable '[IndexType] Type where -- > empty = mkEmpty (ixFun getIndexes) -- --- This is the recommended way to create indexes. +-- This is the recommended way to create indices. -- ixFun :: Ord ix => (a -> [ix]) -> Ix ix a ixFun = Ix Map.empty - -- | Create a generic index. Provided example is used only as type source -- so you may use a 'Proxy'. This uses flatten to traverse values using -- their 'Data' instances. @@ -355,70 +481,12 @@ ixGen :: forall proxy a ix. (Ord ix, Data a, Typeable ix) => proxy ix -> Ix ix a ixGen _proxy = ixFun (flatten :: a -> [ix]) -{- -showTypeOf :: (Typeable a) => a -> String -showTypeOf x = showsPrec 11 (typeOf x) [] --} - -instance Indexable ixs a => Eq (IxSet ixs a) where - IxSet a _ == IxSet b _ = a == b - -instance Indexable ixs a => Ord (IxSet ixs a) where - compare (IxSet a _) (IxSet b _) = compare a b - -{- FIXME -instance Version (IxSet a) -instance (Serialize a, Ord a, Typeable a, Indexable a) => Serialize (IxSet a) where - putCopy = contain . safePut . toList - getCopy = contain $ liftM fromList safeGet --} - -instance (Indexable ixs a, SafeCopy a) => SafeCopy (IxSet ixs a) where - putCopy = contain . safePut . toList - getCopy = contain $ fmap fromList safeGet - -{- -instance ( SYBWC.Data ctx a - , SYBWC.Data ctx [a] - , SYBWC.Sat (ctx (IxSet a)) - , SYBWC.Sat (ctx [a]) - , Indexable a - , Data a - , Ord a - ) - => SYBWC.Data ctx (IxSet a) where - gfoldl _ f z ixset = z fromList `f` toList ixset - toConstr _ (IxSet _) = ixSetConstr - gunfold _ k z c = case SYBWC.constrIndex c of - 1 -> k (z fromList) - _ -> error "IxSet.SYBWC.Data.gunfold unexpected match" - dataTypeOf _ _ = ixSetDataType - -ixSetConstr :: SYBWC.Constr -ixSetConstr = SYBWC.mkConstr ixSetDataType "IxSet" [] SYBWC.Prefix -ixSetDataType :: SYBWC.DataType -ixSetDataType = SYBWC.mkDataType "IxSet" [ixSetConstr] --} - -{- FIXME -instance (Indexable a, Ord a,Data a, Default a) => Default (IxSet a) where - defaultValue = empty --} -instance (Indexable ixs a, Show a) => Show (IxSet ixs a) where - showsPrec prec = showsPrec prec . toSet - -instance (Indexable ixs a, Read a) => Read (IxSet ixs a) where - readsPrec n = map (first fromSet) . readsPrec n - --- | Defines objects that can be members of 'IxSet'. -class (All Ord ixs, Ord a) => Indexable ixs a where - -- | Defines what an empty 'IxSet' for this particular type should look - -- like. It should have all necessary indexes. Use the 'mkEmpty' - -- function to create the set and fill it in with 'ixFun' and 'ixGen'. - empty :: IxSet ixs a +-------------------------------------------------------------------------- +-- 'IxSet' construction via Template Haskell +-------------------------------------------------------------------------- --- | Function to be used for 'calcs' in 'inferIxSet' when you don't --- want any calculated values. +-- | Function to be used as third argument in 'inferIxSet' +-- when you don't want any calculated values. noCalcs :: t -> () noCalcs _ = () @@ -426,17 +494,24 @@ -- 'Indexable' instance from a data type, e.g. -- -- > data Foo = Foo Int String +-- > deriving (Eq, Ord, Data, Typeable) -- -- and -- --- > $(inferIxSet "FooDB" ''Foo 'noCalcs [''Int,''String]) +-- > inferIxSet "FooDB" ''Foo 'noCalcs [''Int, ''String] -- --- will build a type synonym +-- will define: -- -- > type FooDB = IxSet '[Int, String] Foo +-- > instance Indexable '[Int, String] Foo where +-- > ... -- --- with @Int@ and @String@ as indexes. +-- with @Int@ and @String@ as indices defined via -- +-- > ixFun (flattenWithCalcs noCalcs) +-- +-- each. +-- -- /WARNING/: This function uses 'flattenWithCalcs' for index generation, -- which in turn uses an SYB type-based traversal. It is often more efficient -- (and sometimes more correct) to explicitly define the indices using @@ -490,14 +565,6 @@ tyVarBndrToName (PlainTV nm) = nm tyVarBndrToName (KindedTV nm _) = nm --- modification operations - -type SetOp = - forall a. Ord a => a -> Set a -> Set a - -type IndexOp = - forall k a. (Ord k,Ord a) => k -> a -> Map k (Set a) -> Map k (Set a) - -- | Generically traverses the argument to find all occurences of -- values of type @b@ and returns them as a list. -- @@ -521,11 +588,21 @@ flattenWithCalcs :: (Data c,Typeable a, Data a, Typeable b) => (a -> c) -> a -> [b] flattenWithCalcs calcs x = flatten (x,calcs x) +-------------------------------------------------------------------------- +-- Modification of 'IxSet's +-------------------------------------------------------------------------- + +type SetOp = + forall a. Ord a => a -> Set a -> Set a + +type IndexOp = + forall k a. (Ord k,Ord a) => k -> a -> Map k (Set a) -> Map k (Set a) + -- | Higher order operator for modifying 'IxSet's. Use this when your -- final function should have the form @a -> 'IxSet' a -> 'IxSet' a@, -- e.g. 'insert' or 'delete'. -change :: forall ixs a. (Indexable ixs a) => - SetOp -> IndexOp -> a -> IxSet ixs a -> IxSet ixs a +change :: forall ixs a. Indexable ixs a + => SetOp -> IndexOp -> a -> IxSet ixs a -> IxSet ixs a change opS opI x (IxSet a indexes) = IxSet (opS x a) v where v :: IxList ixs a @@ -541,8 +618,8 @@ index' :: Map ix (Set a) index' = List.foldl' ii index ds -insertList :: forall ixs a. (Indexable ixs a) - => [a] -> IxSet ixs a -> IxSet ixs a +insertList :: forall ixs a. Indexable ixs a + => [a] -> IxSet ixs a -> IxSet ixs a insertList xs (IxSet a indexes) = IxSet (List.foldl' (\ b x -> Set.insert x b) a xs) v where v :: IxList ixs a @@ -589,7 +666,7 @@ ix :: Map ix (Set a) ix = Ix.insertList dss partialindex - -- Update function for all other indexes. + -- Update function for all other indices. updatet :: forall ix'. Ord ix' => Ix ix' a -> Ix ix' a updatet (Ix _ f) = Ix ix f where @@ -626,10 +703,12 @@ deleteIx i ixset = maybe ixset (flip delete ixset) $ getOne $ ixset @= i --- conversion operations +-------------------------------------------------------------------------- +-- Conversions +-------------------------------------------------------------------------- -- | Converts an 'IxSet' to a 'Set' of its elements. -toSet :: Ord a => IxSet ixs a -> Set a +toSet :: IxSet ixs a -> Set a toSet (IxSet a _) = a -- | Converts a 'Set' to an 'IxSet'. @@ -641,11 +720,11 @@ fromList list = insertList list empty -- | Returns the number of unique items in the 'IxSet'. -size :: Ord a => IxSet ixs a -> Int +size :: IxSet ixs a -> Int size = Set.size . toSet -- | Converts an 'IxSet' to its list of elements. -toList :: Ord a => IxSet ixs a -> [a] +toList :: IxSet ixs a -> [a] toList = Set.toList . toSet -- | Converts an 'IxSet' to its list of elements. @@ -679,7 +758,9 @@ null :: IxSet ixs a -> Bool null (IxSet a _) = Set.null a --- set operations +-------------------------------------------------------------------------- +-- Set operations +-------------------------------------------------------------------------- -- | An infix 'intersection' operation. (&&&) :: Indexable ixs a => IxSet ixs a -> IxSet ixs a -> IxSet ixs a @@ -706,7 +787,9 @@ (zipWithIxList (\ (Ix a f) (Ix b _) -> Ix (Ix.intersection a b) f) x1 x2) -- TODO: function is taken from the first --- query operators +-------------------------------------------------------------------------- +-- Query operations +-------------------------------------------------------------------------- -- | Infix version of 'getEQ'. (@=) :: (Indexable ixs a, IsIndexOf ix ixs) @@ -733,22 +816,22 @@ => IxSet ixs a -> ix -> IxSet ixs a ix @>= v = getGTE v ix --- | Returns the subset with indexes in the open interval (k,k). +-- | Returns the subset with indices in the open interval (k,k). (@><) :: (Indexable ixs a, IsIndexOf ix ixs) => IxSet ixs a -> (ix, ix) -> IxSet ixs a ix @>< (v1,v2) = getLT v2 $ getGT v1 ix --- | Returns the subset with indexes in [k,k). +-- | Returns the subset with indices in [k,k). (@>=<) :: (Indexable ixs a, IsIndexOf ix ixs) => IxSet ixs a -> (ix, ix) -> IxSet ixs a ix @>=< (v1,v2) = getLT v2 $ getGTE v1 ix --- | Returns the subset with indexes in (k,k]. +-- | Returns the subset with indices in (k,k]. (@><=) :: (Indexable ixs a, IsIndexOf ix ixs) => IxSet ixs a -> (ix, ix) -> IxSet ixs a ix @><= (v1,v2) = getLTE v2 $ getGT v1 ix --- | Returns the subset with indexes in [k,k]. +-- | Returns the subset with indices in [k,k]. (@>=<=) :: (Indexable ixs a, IsIndexOf ix ixs) => IxSet ixs a -> (ix, ix) -> IxSet ixs a ix @>=<= (v1,v2) = getLTE v2 $ getGTE v1 ix @@ -758,7 +841,7 @@ => IxSet ixs a -> [ix] -> IxSet ixs a ix @+ list = List.foldl' union empty $ map (ix @=) list --- | Creates the subset that matches all the provided indexes. +-- | Creates the subset that matches all the provided indices. (@*) :: (Indexable ixs a, IsIndexOf ix ixs) => IxSet ixs a -> [ix] -> IxSet ixs a ix @* list = List.foldl' intersection ix $ map (ix @=) list @@ -806,7 +889,7 @@ => ix -> ix -> IxSet ixs a -> IxSet ixs a getRange k1 k2 ixset = getGTE k1 (getLT k2 ixset) --- | Returns lists of elements paired with the indexes determined by +-- | Returns lists of elements paired with the indices determined by -- type inference. groupBy :: forall ix ixs a. IsIndexOf ix ixs => IxSet ixs a -> [(ix, [a])] groupBy (IxSet _ indexes) = f (access indexes) @@ -814,7 +897,7 @@ f :: Ix ix a -> [(ix, [a])] f (Ix index _) = map (second Set.toList) (Map.toList index) --- | Returns lists of elements paired with the indexes determined by +-- | Returns lists of elements paired with the indices determined by -- type inference. -- -- The resulting list will be sorted in ascending order by 'ix'. @@ -825,7 +908,7 @@ f :: Ix ix a -> [(ix, [a])] f (Ix index _) = map (second Set.toAscList) (Map.toAscList index) --- | Returns lists of elements paired with the indexes determined by +-- | Returns lists of elements paired with the indices determined by -- type inference. -- -- The resulting list will be sorted in descending order by 'ix'. @@ -840,8 +923,6 @@ f :: Ix ix a -> [(ix, [a])] f (Ix index _) = map (second Set.toAscList) (Map.toDescList index) ---query impl function - -- | A function for building up selectors on 'IxSet's. Used in the -- various get* functions. The set must be indexed over key type, -- doing otherwise results in runtime error. @@ -880,35 +961,28 @@ Just eqset -> Map.insertWith Set.union v eqset ltgt Nothing -> ltgt -{-- -Optimization todo: - -* can we avoid rebuilding the collection every time we query? - does laziness take care of everything? - -* nicer operators? - -* nice way to do updates that doesn't involve reinserting the entire data - -* can we index on xpath rather than just type? - ---} - -instance (Indexable ixs a) => Monoid (IxSet ixs a) where - mempty = empty - mappend = union +-- Optimization todo: +-- +-- * can we avoid rebuilding the collection every time we query? +-- does laziness take care of everything? +-- +-- * nicer operators? +-- +-- * nice way to do updates that doesn't involve reinserting the entire data +-- +-- * can we index on xpath rather than just type? -- | Statistics about 'IxSet'. This function returns quadruple -- consisting of -- -- 1. total number of elements in the set --- 2. number of declared indexes --- 3. number of keys in all indexes --- 4. number of values in all keys in all indexes. +-- 2. number of declared indices +-- 3. number of keys in all indices +-- 4. number of values in all keys in all indices. -- -- This can aid you in debugging and optimisation. -- -stats :: (Indexable ixs a) => IxSet ixs a -> (Int,Int,Int,Int) +stats :: Indexable ixs a => IxSet ixs a -> (Int,Int,Int,Int) stats (IxSet a ixs) = (no_elements,no_indexes,no_keys,no_values) where no_elements = Set.size a diff --git a/src/Data/IxSet/Typed/Ix.hs b/src/Data/IxSet/Typed/Ix.hs --- a/src/Data/IxSet/Typed/Ix.hs +++ b/src/Data/IxSet/Typed/Ix.hs @@ -21,6 +21,7 @@ ) where +import Control.DeepSeq -- import Data.Generics hiding (GT) -- import qualified Data.Generics.SYB.WithClass.Basics as SYBWC import qualified Data.List as List @@ -35,6 +36,9 @@ -- values (of type 'a') for that key. data Ix (ix :: *) (a :: *) where Ix :: Map ix (Set a) -> (a -> [ix]) -> Ix ix a + +instance (NFData ix, NFData a) => NFData (Ix ix a) where + rnf (Ix m f) = rnf m `seq` f `seq` () -- deriving instance Typeable (Ix ix a) diff --git a/tests/Data/IxSet/Typed/Tests.hs b/tests/Data/IxSet/Typed/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Data/IxSet/Typed/Tests.hs @@ -0,0 +1,291 @@ +{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, OverlappingInstances, UndecidableInstances, TemplateHaskell, DataKinds, FlexibleInstances, MultiParamTypeClasses, TypeOperators #-} +{-# OPTIONS_GHC -fdefer-type-errors -fno-warn-orphans #-} + +-- TODO (only if SYBWC is added again): +-- Check that the SYBWC Data instance for IxSet works, by testing +-- that going to and from XML works. + +module Data.IxSet.Typed.Tests where + +import Control.Monad +import Control.Exception +import Data.Data (Data, Typeable) +import Data.IxSet.Typed as IxSet +import Data.Maybe +import qualified Data.Set as Set +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +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) + +fooCalcs :: Foo -> String +fooCalcs (Foo s _) = s ++ "bar" + +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] +inferIxSet "Foos" ''Foo 'fooCalcs [''String, ''Int] + +instance Indexable '[Int] S where + empty = mkEmpty (ixFun (\ (S x) -> [length x])) + +ixSetCheckMethodsOnDefault :: TestTree +ixSetCheckMethodsOnDefault = + testGroup "check methods on default" $ + [ testCase "size is zero" $ + 0 @=? size (IxSet.empty :: Foos) + , testCase "getOne returns Nothing" $ + Nothing @=? getOne (IxSet.empty :: Foos) + , testCase "getOneOr returns default" $ + Foo1 "" 44 @=? getOneOr (Foo1 "" 44) (IxSet.empty :: FooXs) + , testCase "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 :: TestTree +ixSetCheckSetMethods = + testGroup "check set methods" $ + [ testCase "size abc is 3" $ + 3 @=? size foox_set_abc + , testCase "size cde is 3" $ + 3 @=? size foox_set_cde + , testCase "getOne returns Nothing" $ + Nothing @=? getOne foox_set_abc + , testCase "getOneOr returns default" $ + Foo1 "" 44 @=? getOneOr (Foo1 "" 44) foox_set_abc + , testCase "toList returns 3 element list" $ + 3 @=? length (toList foox_set_abc) + ] + +isError :: a -> Assertion +isError x = do + r <- try (return $! x) + case r of + Left (ErrorCall _) -> return () + Right _ -> assertFailure $ "Exception expected, but call was successful." + +badIndexSafeguard :: TestTree +badIndexSafeguard = + testGroup "bad index safeguard" $ + [ -- TODO: the following is no longer an error. find a replacement test? + -- testCase "check if there is error when no first index on value" $ + -- isError (size (insert (BadlyIndexed 123) empty :: BadlyIndexeds)) -- TODO: type sig now necessary + -- TODO / GOOD: this is a type error now + testCase "check if indexing with missing index" $ + isError (getOne (foox_set_cde @= True)) -- TODO: should actually verify it's a type error + ] + +testTriple :: TestTree +testTriple = + testGroup "Triple" + [ testCase "check if we can find element" $ + 1 @=? size ((insert (Triple 1 2 3) empty :: Triples) -- TODO: type sig now necessary + @= (1::Int) @= (2::Int)) + ] + + +instance Arbitrary Foo where + arbitrary = liftM2 Foo arbitrary arbitrary + +instance (Arbitrary a, Indexable (ix ': ixs) a) + => Arbitrary (IxSet (ix ': ixs) a) where + arbitrary = liftM fromList arbitrary + +prop_sizeEqToListLength :: Foos -> Bool +prop_sizeEqToListLength ixset = size ixset == length (toList ixset) + +sizeEqToListLength :: TestTree +sizeEqToListLength = + testProperty "size === length . toList" $ prop_sizeEqToListLength + +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_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) + +setOps :: TestTree +setOps = testGroup "set operations" $ + [ testProperty "distributivity toSet / union" $ prop_union + , testProperty "distributivity toSet / intersection" $ prop_intersection + , testProperty "any (@+)" $ prop_any + , testProperty "all (@*)" $ prop_all + ] + +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 + +opers :: TestTree +opers = testProperty "query operators" $ prop_opers + +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 + +sureelem :: TestTree +sureelem = testProperty "query / insert interaction" $ prop_sureelem + +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 + +ranges :: TestTree +ranges = testProperty "ranges" $ prop_ranges + +funSet :: IxSet '[Int] S +funSet = IxSet.fromList [S "", S "abc", S "def", S "abcde"] + +funIndexes :: TestTree +funIndexes = + testGroup "ixFun indices" $ + [ testCase "has zero length element" $ + 1 @=? size (funSet @= (0 :: Int)) + , testCase "has two lengh 3 elements" $ + 2 @=? size (funSet @= (3 :: Int)) + , testCase "has three lengh [3;7] elements" $ + 3 @=? size (funSet @>=<= (3 :: Int, 7 :: Int)) + ] + +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 + +multiIndexed :: TestTree +multiIndexed = + testGroup "MultiIndexed" $ + [ testCase "find an element" (True @=? findElement 1 1) + ] + +allTests :: TestTree +allTests = + testGroup "ixset-typed tests" $ + [ testGroup "unit tests" $ + [ ixSetCheckMethodsOnDefault + , ixSetCheckSetMethods + , badIndexSafeguard + , multiIndexed + , testTriple + , funIndexes + ] + , testGroup "properties" $ + [ sizeEqToListLength + , setOps + , opers + , sureelem + , ranges + ] + ] diff --git a/tests/TestIxSetTyped.hs b/tests/TestIxSetTyped.hs new file mode 100644 --- /dev/null +++ b/tests/TestIxSetTyped.hs @@ -0,0 +1,7 @@ +module Main where + +import Test.Tasty +import Data.IxSet.Typed.Tests (allTests) + +main :: IO () +main = defaultMain allTests