ixset-typed-0.5/0000755000000000000000000000000007346545000012026 5ustar0000000000000000ixset-typed-0.5/CHANGELOG.md0000755000000000000000000000343507346545000013647 0ustar00000000000000000.5 (2020-03-18) ================ - GHC 8.8 (and possibly 8.10) compatibility. - safecopy-0.10 compatibility. 0.4.0.1 (2018-10-01) ==================== - containers-0.6 compatibility. 0.4 (2018-03-18) ================ * GHC 8.4 compatibility. * Drop compatibility with GHC 7. GHC 8.4 introduces `Semigroup` as a superclass for monoid, and `Semigroup` is not in `base` prior to GHC 8. To avoid a conditional interface or a dependency on the `semigroups` package, we drop compatibility with GHC 7. There are not other changes in this version, so `ixset-typed-0.3.1.1` remains usable with GHC 7. 0.3.1.1 (2017-08-14) ==================== * GHC 8.2 compatibility. 0.3.1 (2016-06-21) ================== * GHC 8.0 compatibility. 0.3 (2014-07-23) ================ * `IxSet` internals are now more strict * The `empty` method of `Indexable` is now called `indices` and has a slightly different path; to migrate your code, if you were using Template Haskell, you probably do not have to change anything. Otherwise, wherever you have an instance of `Indexable` that looks like this instance Indexable MyIndexSet MyType where -- OLD empty = mkEmpty ... change it to instance Indexable MyIndexSet MyType where -- NEW indices = ixList ... 0.2 (2014-04-06) ================ * Add testsuite (which is a port of the ixset testsuite). * Cleaning up and documentation. * Add 'Foldable' and 'NFData' instances. 0.1.4 (2014-04-03) ================== * Documentation. 0.1.3 (2014-04-02) ================== * Export `IsIndexOf` class. 0.1.2 (2014-04-02) ================== * Clean up export list. * Documentation. 0.1.1 (2014-04-02) ================== * Clean up export list. * Documentation. 0.1.0.0 (2014-03-31) ==================== * Initial release. ixset-typed-0.5/COPYING0000644000000000000000000000273407346545000013067 0ustar0000000000000000Copyright (c) 2014, Well-Typed LLP Copyright (c) 2006, HAppS.org All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. Neither the name of the HAppS.org; nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ixset-typed-0.5/Setup.hs0000644000000000000000000000011007346545000013452 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMain ixset-typed-0.5/ixset-typed.cabal0000644000000000000000000000506007346545000015272 0ustar0000000000000000name: ixset-typed version: 0.5 synopsis: Efficient relational queries on Haskell sets. description: This Haskell package provides a data structure of sets that are indexed by potentially multiple indices. . Sets can be created, modified, and queried in various ways. . The package is a variant of the package. The ixset package makes use of run-time type information to find a suitable index on a query, resulting in possible run-time errors when no suitable index exists. In ixset-typed, the types of all indices available or tracked in the type system. Thus, ixset-typed should be safer to use than ixset, but in turn requires more GHC extensions. . At the moment, the two packages are relatively compatible. As a consequence of the more precise types, a few manual tweaks are necessary when switching from one to the other, but the interface is mostly the same. license: BSD3 license-file: COPYING author: Andres Löh, Happstack team, HAppS LLC maintainer: Andres Löh category: Data Structures build-type: Simple cabal-version: >= 1.10 extra-source-files: CHANGELOG.md tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1, GHC == 8.8.1 source-repository head type: git location: https://github.com/well-typed/ixset-typed.git library build-depends: base >= 4.9 && < 5, containers >= 0.5 && < 1, deepseq >= 1.3 && < 2, safecopy >= 0.8 && < 0.11, syb >= 0.4 && < 1, template-haskell >= 2.8 && < 2.17 hs-source-dirs: src exposed-modules: Data.IxSet.Typed Data.IxSet.Typed.Ix ghc-options: -Wall -fno-warn-unused-do-bind default-language: Haskell2010 test-suite test-ixset-typed type: exitcode-stdio-1.0 build-depends: ixset-typed, base >= 4.9 && < 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 ixset-typed-0.5/src/Data/IxSet/0000755000000000000000000000000007346545000014522 5ustar0000000000000000ixset-typed-0.5/src/Data/IxSet/Typed.hs0000644000000000000000000010742007346545000016147 0ustar0000000000000000{-# LANGUAGE UndecidableInstances, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, RankNTypes, FunctionalDependencies, DeriveDataTypeable, GADTs, CPP, ScopedTypeVariables, KindSignatures, DataKinds, TypeOperators, StandaloneDeriving, TypeFamilies, ScopedTypeVariables, ConstraintKinds, FunctionalDependencies, FlexibleContexts, BangPatterns #-} #if __GLASGOW_HASKELL__ < 710 {-# LANGUAGE OverlappingInstances #-} #endif #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE UndecidableSuperClasses #-} #endif {- | An efficient implementation of queryable sets. Assume you have a family of types such as: > data Entry = Entry Author [Author] Updated Id Content > deriving (Show, Eq, Ord, Data, Typeable) > newtype Updated = Updated UTCTime > deriving (Show, Eq, Ord, Data, Typeable) > newtype Id = Id Int64 > deriving (Show, Eq, Ord, Data, Typeable) > newtype Content = Content String > deriving (Show, Eq, Ord, Data, Typeable) > newtype Author = Author Email > deriving (Show, Eq, Ord, Data, Typeable) > type Email = String > data Test = Test > 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 indices: > type EntryIxs = '[Author, Id, Updated, Test] > type IxEntry = IxSet EntryIxs Entry > > instance Indexable EntryIxs Entry where > indices = ixList > (ixGen (Proxy :: Proxy Author)) -- out of order > (ixGen (Proxy :: Proxy Id)) > (ixGen (Proxy :: Proxy Updated)) > (ixGen (Proxy :: Proxy Test)) -- bogus index The use of 'ixGen' requires the 'Data' and 'Typeable' instances above. You can build indices manually using 'ixFun'. You can also use the Template Haskell function 'inferIxSet' to generate an 'Indexable' instance automatically. 2. Use 'insert', 'insertList', 'delete', 'updateIx', 'deleteIx' and 'empty' to build up an 'IxSet' collection: > entries = insertList [e1, e2, e3, e4] (empty :: IxEntry) > entries1 = foldr delete entries [e1, e3] > entries2 = updateIx (Id 4) e5 entries 3. Use the query functions below to grab data from it: > entries @= Author "john@doe.com" @< Updated t1 Statement above will find all items in entries updated earlier than @t1@ by @john\@doe.com@. 4. Text index If you want to do add a text index create a calculated index. Then if you want all entries with either @word1@ or @word2@, you change the instance to: > newtype Word = Word String > deriving (Show, Eq, Ord) > > getWords (Entry _ _ _ _ (Content s)) = map Word $ words s > > type EntryIxs = '[..., Word] > instance Indexable EntryIxs Entry where > indices = ixList > ... > (ixFun getWords) Now you can do this query to find entries with any of the words: > entries @+ [Word "word1", Word "word2"] And if you want all entries with both: > entries @* [Word "word1", Word "word2"] 5. Find only the first author If an @Entry@ has multiple authors and you want to be able to query on the first author only, define a @FirstAuthor@ datatype and create an index with this type. Now you can do: > newtype FirstAuthor = FirstAuthor Email > deriving (Show, Eq, Ord) > > getFirstAuthor (Entry author _ _ _ _) = [FirstAuthor author] > > type EntryIxs = '[..., FirstAuthor] > instance Indexable EntryIxs Entry where > indices = ixList > ... > (ixFun getFirstAuthor) > entries @= (FirstAuthor "john@doe.com") -- guess what this does -} module Data.IxSet.Typed ( -- * Set type IxSet(), IxList(), Indexable(..), IsIndexOf(), All, -- ** Declaring indices Ix(), ixList, MkIxList(), ixFun, ixGen, -- ** TH derivation of indices noCalcs, inferIxSet, -- * Changes to set IndexOp, SetOp, change, insert, insertList, delete, updateIx, deleteIx, -- * Creation empty, fromSet, fromList, -- * Conversion toSet, toList, toAscList, toDescList, getOne, getOneOr, -- * Size checking size, null, -- * Set operations (&&&), (|||), union, intersection, -- * Indexing (@=), (@<), (@>), (@<=), (@>=), (@><), (@>=<), (@><=), (@>=<=), (@+), (@*), getEQ, getLT, getGT, getLTE, getGTE, getRange, groupBy, groupAscBy, groupDescBy, indexKeys, -- * Index creation helpers flatten, flattenWithCalcs, -- * Debugging and optimization stats ) where 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 import Data.IxSet.Typed.Ix (Ix(Ix)) import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe) import Data.Monoid (Monoid(mempty, mappend)) import Data.SafeCopy (SafeCopy(..), contain, safeGet, safePut) import Data.Semigroup (Semigroup(..)) import Data.Set (Set) import qualified Data.Set as Set import Data.Typeable (Typeable, cast {- , typeOf -}) import Language.Haskell.TH as TH import GHC.Exts (Constraint) -------------------------------------------------------------------------- -- The main 'IxSet' datatype. -------------------------------------------------------------------------- -- | Set with associated indices. -- -- The type-level list 'ixs' contains all types that are valid index keys. -- The type 'a' is the type of elements in the indexed set. -- -- On strictness: An 'IxSet' is "mostly" spine-strict. It is generally -- spine-strict in the set itself. All operations on 'IxSet' with the -- exception of queries are spine-strict in the indices as well. Query -- operations, however, are lazy in the indices, so querying a number of -- times and subsequently selecting the result will not unnecessarily -- rebuild all indices. -- data IxSet (ixs :: [*]) (a :: *) where IxSet :: !(Set a) -> !(IxList ixs a) -> IxSet ixs a data IxList (ixs :: [*]) (a :: *) where Nil :: IxList '[] a (:::) :: Ix ix a -> IxList ixs a -> IxList (ix ': ixs) a infixr 5 ::: -- | A strict variant of ':::'. (!:::) :: Ix ix a -> IxList ixs a -> IxList (ix ': ixs) a (!:::) !ix !ixs = ix ::: ixs 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 -------------------------------------------------------------------------- -- 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@. -- -- Example: -- -- > All Ord '[Int, Char, Bool] -- -- is equivalent to -- -- > (Ord Int, Ord Char, Ord Bool) -- type family All (c :: * -> Constraint) (xs :: [*]) :: Constraint 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 how the indices for this particular type should look like. -- -- Use the 'ixList' function to construct the list of indices, and use -- 'ixFun' (or 'ixGen') for individual indices. indices :: IxList 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. -- -- The function 'mapAt' is lazy in the index list structure, -- because it is used by query operations. 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 #if __GLASGOW_HASKELL__ >= 710 {-# OVERLAPPING #-} #endif Ord ix => IsIndexOf ix (ix ': ixs) where access (x ::: _xs) = x mapAt fh ft (x ::: xs) = fh x ::: mapIxList ft xs instance #if __GLASGOW_HASKELL__ >= 710 {-# OVERLAPPABLE #-} #endif 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 where go :: forall ixs'. Int -> IxList ixs' a -> Int go !acc Nil = acc go !acc (_ ::: xs) = go (acc + 1) xs -- | 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 -- | 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 -- | Map over an index list (spine-strict). 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 -- | Zip two index lists of compatible type (spine-strict). 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 #if __GLASGOW_HASKELL__ < 800 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 #endif -------------------------------------------------------------------------- -- Various instances for 'IxSet' -------------------------------------------------------------------------- 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 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, Typeable ixs, SafeCopy a, Typeable 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 => Semigroup (IxSet ixs a) where (<>) = mappend 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 -------------------------------------------------------------------------- -- | An empty 'IxSet'. empty :: Indexable ixs a => IxSet ixs a empty = IxSet Set.empty indices -- | Create an (empty) 'IxList' from a number of indices. Useful in the 'Indexable' -- 'indices' 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: -- -- > ixList :: Ix ix1 a -> IxList '[ix1] a -- > ixList :: Ix ix1 a -> Ix ix2 a -> IxList '[ix1, ix2] a -- > ixList :: Ix ix1 a -> Ix ix2 a -> Ix ix3 a -> IxList '[ix1, ix2, ix3] a -- > ixList :: ... -- -- Concrete example use: -- -- > instance Indexable '[..., Index1Type, Index2Type] Type where -- > indices = ixList -- > ... -- > (ixFun getIndex1) -- > (ixGen (Proxy :: Proxy Index2Type)) -- ixList :: MkIxList ixs ixs a r => r ixList = ixList' id -- | Class that allows a variable number of arguments to be passed to the -- 'ixSet' and 'mkEmpty' functions. See the documentation of these functions -- for more information. class MkIxList ixs ixs' a r | r -> a ixs ixs' where ixList' :: (IxList ixs a -> IxList ixs' a) -> r instance MkIxList '[] ixs a (IxList ixs a) where ixList' acc = acc Nil instance MkIxList ixs ixs' a r => MkIxList (ix ': ixs) ixs' a (Ix ix a -> r) where ixList' acc ix = ixList' (\ x -> acc (ix ::: x)) -- | Create a functional index. Provided function should return a list -- of indices where the value should be found. -- -- > getIndices :: Type -> [IndexType] -- > getIndices value = [...indices...] -- -- > instance Indexable '[IndexType] Type where -- > indices = ixList (ixFun getIndices) -- -- 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. -- -- > instance Indexable '[IndexType] Type where -- > indices = ixList (ixGen (Proxy :: Proxy Type)) -- -- In production systems consider using 'ixFun' in place of 'ixGen' as -- the former one is much faster. -- ixGen :: forall proxy a ix. (Ord ix, Data a, Typeable ix) => proxy ix -> Ix ix a ixGen _proxy = ixFun (flatten :: a -> [ix]) -------------------------------------------------------------------------- -- 'IxSet' construction via Template Haskell -------------------------------------------------------------------------- -- | Function to be used as third argument in 'inferIxSet' -- when you don't want any calculated values. noCalcs :: t -> () noCalcs _ = () -- | Template Haskell helper function for automatically building an -- '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] -- -- will define: -- -- > type FooDB = IxSet '[Int, String] Foo -- > instance Indexable '[Int, String] Foo where -- > ... -- -- 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 -- 'ixFun'. -- inferIxSet :: String -> TH.Name -> TH.Name -> [TH.Name] -> Q [Dec] inferIxSet _ _ _ [] = error "inferIxSet needs at least one index" inferIxSet ixset typeName calName entryPoints = do calInfo <- reify calName typeInfo <- reify typeName let (context,binders) = case typeInfo of #if MIN_VERSION_template_haskell(2,11,0) TyConI (DataD ctxt _ nms _ _ _) -> (ctxt,nms) TyConI (NewtypeD ctxt _ nms _ _ _) -> (ctxt,nms) #else TyConI (DataD ctxt _ nms _ _) -> (ctxt,nms) TyConI (NewtypeD ctxt _ nms _ _) -> (ctxt,nms) #endif TyConI (TySynD _ nms _) -> ([],nms) _ -> error "IxSet.inferIxSet typeInfo unexpected match" names = map tyVarBndrToName binders typeCon = List.foldl' appT (conT typeName) (map varT names) #if MIN_VERSION_template_haskell(2,10,0) mkCtx c = List.foldl' appT (conT c) #else mkCtx = classP #endif dataCtxConQ = concat [[mkCtx ''Data [varT name], mkCtx ''Ord [varT name]] | name <- names] fullContext = do dataCtxCon <- sequence dataCtxConQ return (context ++ dataCtxCon) case calInfo of #if MIN_VERSION_template_haskell(2,11,0) VarI _ _t _ -> #else VarI _ _t _ _ -> #endif let {- calType = getCalType t getCalType (ForallT _names _ t') = getCalType t' getCalType (AppT (AppT ArrowT _) t') = t' getCalType t' = error ("Unexpected type in getCalType: " ++ pprint t') -} mkEntryPoint n = (conE 'Ix) `appE` (sigE (varE 'Map.empty) (forallT binders (return context) $ appT (appT (conT ''Map) (conT n)) (appT (conT ''Set) typeCon))) `appE` (varE 'flattenWithCalcs `appE` varE calName) mkTypeList :: [TypeQ] -> TypeQ mkTypeList = foldr (\ x xs -> promotedConsT `appT` x `appT` xs) promotedNilT typeList :: TypeQ typeList = mkTypeList (map conT entryPoints) in do i <- instanceD (fullContext) (conT ''Indexable `appT` typeList `appT` typeCon) [valD (varP 'indices) (normalB (appsE ([| ixList |] : map mkEntryPoint entryPoints))) []] let ixType = conT ''IxSet `appT` typeList `appT` typeCon ixType' <- tySynD (mkName ixset) binders ixType return $ [i, ixType'] -- ++ d _ -> error "IxSet.inferIxSet calInfo unexpected match" tyVarBndrToName :: TyVarBndr -> Name tyVarBndrToName (PlainTV nm) = nm tyVarBndrToName (KindedTV nm _) = nm -- | Generically traverses the argument to find all occurences of -- values of type @b@ and returns them as a list. -- -- This function properly handles 'String' as 'String' not as @['Char']@. flatten :: (Typeable a, Data a, Typeable b) => a -> [b] flatten x = case cast x of Just y -> case cast (y :: String) of Just v -> [v] Nothing -> [] Nothing -> case cast x of Just v -> v : concat (gmapQ flatten x) Nothing -> concat (gmapQ flatten x) -- | Generically traverses the argument and calculated values to find -- all occurences of values of type @b@ and returns them as a -- list. Equivalent to: -- -- > flatten (x,calcs x) -- -- This function properly handles 'String' as 'String' not as @['Char']@. 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 opS opI x (IxSet a indexes) = IxSet (opS x a) v where v :: IxList ixs a v = mapIxList' update indexes update :: forall ix. Ord ix => Ix ix a -> Ix ix a update (Ix index f) = Ix index' f where ds :: [ix] ds = f x ii :: forall k. Ord k => Map k (Set a) -> k -> Map k (Set a) ii m dkey = opI dkey x m 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 xs (IxSet a indexes) = IxSet (List.foldl' (\ b x -> Set.insert x b) a xs) v where v :: IxList ixs a v = mapIxList' update indexes update :: forall ix. Ord ix => Ix ix a -> Ix ix a update (Ix index f) = Ix index' f where dss :: [(ix, a)] dss = [(k, x) | x <- xs, k <- f x] index' :: Map ix (Set a) index' = Ix.insertList dss index -- | Internal helper function that takes a partial index from one index -- set and rebuilds the rest of the structure of the index set. -- -- Slightly rewritten comment from original version regarding dss / index': -- -- We try to be really clever here. The partialindex is a Map of Sets -- from original index. We want to reuse it as much as possible. If there -- was a guarantee that each element is present at at most one key we -- could reuse originalindex as it is. But there can be more, so we need to -- add remaining ones (in updateh). Anyway we try to reuse old structure and -- keep new allocations low as much as possible. fromMapOfSets :: forall ixs ix a. (Indexable ixs a, IsIndexOf ix ixs) => Map ix (Set a) -> IxSet ixs a fromMapOfSets partialindex = IxSet a (mapAt updateh updatet indices) where a :: Set a a = Set.unions (Map.elems partialindex) xs :: [a] xs = Set.toList a -- Update function for the index corresponding to partialindex. updateh :: Ix ix a -> Ix ix a updateh (Ix _ f) = Ix ix f where dss :: [(ix, a)] dss = [(k, x) | x <- xs, k <- f x, not (Map.member k partialindex)] ix :: Map ix (Set a) ix = Ix.insertList dss partialindex -- Update function for all other indices. updatet :: forall ix'. Ord ix' => Ix ix' a -> Ix ix' a updatet (Ix _ f) = Ix ix f where dss :: [(ix', a)] dss = [(k, x) | x <- xs, k <- f x] ix :: Map ix' (Set a) ix = Ix.fromList dss -- | Inserts an item into the 'IxSet'. If your data happens to have -- a primary key this function might not be what you want. See -- 'updateIx'. insert :: Indexable ixs a => a -> IxSet ixs a -> IxSet ixs a insert = change Set.insert Ix.insert -- | Removes an item from the 'IxSet'. delete :: Indexable ixs a => a -> IxSet ixs a -> IxSet ixs a delete = change Set.delete Ix.delete -- | Will replace the item with the given index of type 'ix'. -- Only works if there is at most one item with that index in the 'IxSet'. -- Will not change 'IxSet' if you have more than one item with given index. updateIx :: (Indexable ixs a, IsIndexOf ix ixs) => ix -> a -> IxSet ixs a -> IxSet ixs a updateIx i new ixset = insert new $ maybe ixset (flip delete ixset) $ getOne $ ixset @= i -- | Will delete the item with the given index of type 'ix'. -- Only works if there is at most one item with that index in the 'IxSet'. -- Will not change 'IxSet' if you have more than one item with given index. deleteIx :: (Indexable ixs a, IsIndexOf ix ixs) => ix -> IxSet ixs a -> IxSet ixs a deleteIx i ixset = maybe ixset (flip delete ixset) $ getOne $ ixset @= i -------------------------------------------------------------------------- -- Conversions -------------------------------------------------------------------------- -- | Converts an 'IxSet' to a 'Set' of its elements. toSet :: IxSet ixs a -> Set a toSet (IxSet a _) = a -- | Converts a 'Set' to an 'IxSet'. fromSet :: (Indexable ixs a) => Set a -> IxSet ixs a fromSet = fromList . Set.toList -- | Converts a list to an 'IxSet'. fromList :: (Indexable ixs a) => [a] -> IxSet ixs a fromList list = insertList list empty -- | Returns the number of unique items in the 'IxSet'. size :: IxSet ixs a -> Int size = Set.size . toSet -- | Converts an 'IxSet' to its list of elements. toList :: IxSet ixs a -> [a] toList = Set.toList . toSet -- | Converts an 'IxSet' to its list of elements. -- -- List will be sorted in ascending order by the index 'ix'. -- -- The list may contain duplicate entries if a single value produces multiple keys. toAscList :: forall proxy ix ixs a. IsIndexOf ix ixs => proxy ix -> IxSet ixs a -> [a] toAscList _ ixset = concatMap snd (groupAscBy ixset :: [(ix, [a])]) -- | Converts an 'IxSet' to its list of elements. -- -- List will be sorted in descending order by the index 'ix'. -- -- The list may contain duplicate entries if a single value produces multiple keys. toDescList :: forall proxy ix ixs a. IsIndexOf ix ixs => proxy ix -> IxSet ixs a -> [a] toDescList _ ixset = concatMap snd (groupDescBy ixset :: [(ix, [a])]) -- | If the 'IxSet' is a singleton it will return the one item stored in it. -- If 'IxSet' is empty or has many elements this function returns 'Nothing'. getOne :: Ord a => IxSet ixs a -> Maybe a getOne ixset = case toList ixset of [x] -> Just x _ -> Nothing -- | Like 'getOne' with a user-provided default. getOneOr :: Ord a => a -> IxSet ixs a -> a getOneOr def = fromMaybe def . getOne -- | Return 'True' if the 'IxSet' is empty, 'False' otherwise. null :: IxSet ixs a -> Bool null (IxSet a _) = Set.null a -------------------------------------------------------------------------- -- Set operations -------------------------------------------------------------------------- -- | An infix 'intersection' operation. (&&&) :: Indexable ixs a => IxSet ixs a -> IxSet ixs a -> IxSet ixs a (&&&) = intersection -- | An infix 'union' operation. (|||) :: Indexable ixs a => IxSet ixs a -> IxSet ixs a -> IxSet ixs a (|||) = union infixr 5 &&& infixr 5 ||| -- | Takes the union of the two 'IxSet's. union :: Indexable ixs a => IxSet ixs a -> IxSet ixs a -> IxSet ixs a union (IxSet a1 x1) (IxSet a2 x2) = IxSet (Set.union a1 a2) (zipWithIxList' (\ (Ix a f) (Ix b _) -> Ix (Ix.union a b) f) x1 x2) -- TODO: function is taken from the first -- | Takes the intersection of the two 'IxSet's. intersection :: Indexable ixs a => IxSet ixs a -> IxSet ixs a -> IxSet ixs a intersection (IxSet a1 x1) (IxSet a2 x2) = IxSet (Set.intersection a1 a2) (zipWithIxList' (\ (Ix a f) (Ix b _) -> Ix (Ix.intersection a b) f) x1 x2) -- TODO: function is taken from the first -------------------------------------------------------------------------- -- Query operations -------------------------------------------------------------------------- -- | Infix version of 'getEQ'. (@=) :: (Indexable ixs a, IsIndexOf ix ixs) => IxSet ixs a -> ix -> IxSet ixs a ix @= v = getEQ v ix -- | Infix version of 'getLT'. (@<) :: (Indexable ixs a, IsIndexOf ix ixs) => IxSet ixs a -> ix -> IxSet ixs a ix @< v = getLT v ix -- | Infix version of 'getGT'. (@>) :: (Indexable ixs a, IsIndexOf ix ixs) => IxSet ixs a -> ix -> IxSet ixs a ix @> v = getGT v ix -- | Infix version of 'getLTE'. (@<=) :: (Indexable ixs a, IsIndexOf ix ixs) => IxSet ixs a -> ix -> IxSet ixs a ix @<= v = getLTE v ix -- | Infix version of 'getGTE'. (@>=) :: (Indexable ixs a, IsIndexOf ix ixs) => IxSet ixs a -> ix -> IxSet ixs a ix @>= v = getGTE v ix -- | 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 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 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 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 -- | Creates the subset that has an index in the provided list. (@+) :: (Indexable ixs a, IsIndexOf ix ixs) => IxSet ixs a -> [ix] -> IxSet ixs a ix @+ list = List.foldl' union empty $ map (ix @=) list -- | 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 -- | Returns the subset with an index equal to the provided key. The -- set must be indexed over key type, doing otherwise results in -- runtime error. getEQ :: (Indexable ixs a, IsIndexOf ix ixs) => ix -> IxSet ixs a -> IxSet ixs a getEQ = getOrd EQ -- | Returns the subset with an index less than the provided key. The -- set must be indexed over key type, doing otherwise results in -- runtime error. getLT :: (Indexable ixs a, IsIndexOf ix ixs) => ix -> IxSet ixs a -> IxSet ixs a getLT = getOrd LT -- | Returns the subset with an index greater than the provided key. -- The set must be indexed over key type, doing otherwise results in -- runtime error. getGT :: (Indexable ixs a, IsIndexOf ix ixs) => ix -> IxSet ixs a -> IxSet ixs a getGT = getOrd GT -- | Returns the subset with an index less than or equal to the -- provided key. The set must be indexed over key type, doing -- otherwise results in runtime error. getLTE :: (Indexable ixs a, IsIndexOf ix ixs) => ix -> IxSet ixs a -> IxSet ixs a getLTE = getOrd2 True True False -- | Returns the subset with an index greater than or equal to the -- provided key. The set must be indexed over key type, doing -- otherwise results in runtime error. getGTE :: (Indexable ixs a, IsIndexOf ix ixs) => ix -> IxSet ixs a -> IxSet ixs a getGTE = getOrd2 False True True -- | Returns the subset with an index within the interval provided. -- The bottom of the interval is closed and the top is open, -- i. e. [k1;k2). The set must be indexed over key type, doing -- otherwise results in runtime error. getRange :: (Indexable ixs a, IsIndexOf ix ixs) => ix -> ix -> IxSet ixs a -> IxSet ixs a getRange k1 k2 ixset = getGTE k1 (getLT k2 ixset) -- | 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) where f :: Ix ix a -> [(ix, [a])] f (Ix index _) = map (second Set.toList) (Map.toList index) -- | Returns the list of index keys being used for a particular index. indexKeys :: forall ix ixs a . IsIndexOf ix ixs => IxSet ixs a -> [ix] indexKeys (IxSet _ indexes) = f (access indexes) where f :: Ix ix a -> [ix] f (Ix index _) = Map.keys index -- | Returns lists of elements paired with the indices determined by -- type inference. -- -- The resulting list will be sorted in ascending order by 'ix'. -- The values in @[a]@ will be sorted in ascending order as well. groupAscBy :: forall ix ixs a. IsIndexOf ix ixs => IxSet ixs a -> [(ix, [a])] groupAscBy (IxSet _ indexes) = f (access indexes) where f :: Ix ix a -> [(ix, [a])] f (Ix index _) = map (second Set.toAscList) (Map.toAscList index) -- | Returns lists of elements paired with the indices determined by -- type inference. -- -- The resulting list will be sorted in descending order by 'ix'. -- -- NOTE: The values in @[a]@ are currently sorted in ascending -- order. But this may change if someone bothers to add -- 'Set.toDescList'. So do not rely on the sort order of the -- resulting list. groupDescBy :: IsIndexOf ix ixs => IxSet ixs a -> [(ix, [a])] groupDescBy (IxSet _ indexes) = f (access indexes) where f :: Ix ix a -> [(ix, [a])] f (Ix index _) = map (second Set.toAscList) (Map.toDescList index) -- | 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. getOrd :: (Indexable ixs a, IsIndexOf ix ixs) => Ordering -> ix -> IxSet ixs a -> IxSet ixs a getOrd LT = getOrd2 True False False getOrd EQ = getOrd2 False True False getOrd GT = getOrd2 False False True -- | 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. getOrd2 :: forall ixs ix a. (Indexable ixs a, IsIndexOf ix ixs) => Bool -> Bool -> Bool -> ix -> IxSet ixs a -> IxSet ixs a getOrd2 inclt inceq incgt v (IxSet _ ixs) = f (access ixs) where f :: Ix ix a -> IxSet ixs a f (Ix index _) = fromMapOfSets result where lt', gt' :: Map ix (Set a) eq' :: Maybe (Set a) (lt', eq', gt') = Map.splitLookup v index lt, gt :: Map ix (Set a) lt = if inclt then lt' else Map.empty gt = if incgt then gt' else Map.empty eq :: Maybe (Set a) eq = if inceq then eq' else Nothing ltgt :: Map ix (Set a) ltgt = Map.unionWith Set.union lt gt result :: Map ix (Set a) result = case eq of 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? -- | Statistics about 'IxSet'. This function returns quadruple -- consisting of -- -- 1. total number of elements in the set -- 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 (IxSet a ixs) = (no_elements,no_indexes,no_keys,no_values) where no_elements = Set.size a no_indexes = lengthIxList ixs no_keys = sum (ixListToList (\ (Ix m _) -> Map.size m) ixs) no_values = sum (ixListToList (\ (Ix m _) -> sum [Set.size s | s <- Map.elems m]) ixs) ixset-typed-0.5/src/Data/IxSet/Typed/0000755000000000000000000000000007346545000015607 5ustar0000000000000000ixset-typed-0.5/src/Data/IxSet/Typed/Ix.hs0000644000000000000000000000741607346545000016533 0ustar0000000000000000{-# LANGUAGE UndecidableInstances, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, PolymorphicComponents, DeriveDataTypeable,ExistentialQuantification, KindSignatures, StandaloneDeriving, GADTs #-} {- | This module defines 'Typeable' indexes and convenience functions. Should probably be considered private to @Data.IxSet.Typed@. -} module Data.IxSet.Typed.Ix ( Ix(..) , insert , delete , fromList , insertList , deleteList , union , intersection ) where import Control.DeepSeq -- import Data.Generics hiding (GT) -- import qualified Data.Generics.SYB.WithClass.Basics as SYBWC import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Map.Strict as Map.Strict import Data.Set (Set) import qualified Data.Set as Set -- the core datatypes -- | 'Ix' is a 'Map' from some key (of type 'ix') to a 'Set' of -- 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) {- -- minimal hacky instance instance Data a => Data (Ix a) where toConstr (Ix _ _) = con_Ix_Data gunfold _ _ = error "gunfold" dataTypeOf _ = ixType_Data -} {- con_Ix_Data :: Constr con_Ix_Data = mkConstr ixType_Data "Ix" [] Prefix ixType_Data :: DataType ixType_Data = mkDataType "Happstack.Data.IxSet.Ix" [con_Ix_Data] -} {- ixConstr :: SYBWC.Constr ixConstr = SYBWC.mkConstr ixDataType "Ix" [] SYBWC.Prefix ixDataType :: SYBWC.DataType ixDataType = SYBWC.mkDataType "Ix" [ixConstr] -} {- instance (SYBWC.Data ctx a, SYBWC.Sat (ctx (Ix a))) => SYBWC.Data ctx (Ix a) where gfoldl = error "gfoldl Ix" toConstr _ (Ix _ _) = ixConstr gunfold = error "gunfold Ix" dataTypeOf _ _ = ixDataType -} -- modification operations -- | Convenience function for inserting into 'Map's of 'Set's as in -- the case of an 'Ix'. If they key did not already exist in the -- '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.Strict.insertWith Set.union k (Set.singleton v) index -- | Helper function to 'insert' a list of elements into a set. insertList :: (Ord a, Ord k) => [(k,a)] -> Map k (Set a) -> Map k (Set a) insertList xs index = List.foldl' (\m (k,v)-> insert k v m) index xs -- | Helper function to create a new index from a list. fromList :: (Ord a, Ord k) => [(k, a)] -> Map k (Set a) fromList xs = Map.fromListWith Set.union (List.map (\ (k, v) -> (k, Set.singleton v)) xs) -- | Convenience function for deleting from 'Map's of 'Set's. If the -- resulting 'Set' is empty, then the entry is removed from the 'Map'. delete :: (Ord a, Ord k) => k -> a -> Map k (Set a) -> Map k (Set a) delete k v index = Map.update remove k index where remove set = let set' = Set.delete v set in if Set.null set' then Nothing else Just set' -- | Helper function to 'delete' a list of elements from a set. deleteList :: (Ord a, Ord k) => [(k,a)] -> Map k (Set a) -> Map k (Set a) deleteList xs index = List.foldl' (\m (k,v) -> delete k v m) index xs -- | Takes the union of two sets. union :: (Ord a, Ord k) => Map k (Set a) -> Map k (Set a) -> Map k (Set a) union index1 index2 = Map.unionWith Set.union index1 index2 -- | Takes the intersection of two sets. intersection :: (Ord a, Ord k) => Map k (Set a) -> Map k (Set a) -> Map k (Set a) intersection index1 index2 = Map.filter (not . Set.null) $ Map.intersectionWith Set.intersection index1 index2 ixset-typed-0.5/tests/Data/IxSet/Typed/0000755000000000000000000000000007346545000016162 5ustar0000000000000000ixset-typed-0.5/tests/Data/IxSet/Typed/Tests.hs0000644000000000000000000002247107346545000017626 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, OverlappingInstances, UndecidableInstances, TemplateHaskell, DataKinds, FlexibleInstances, MultiParamTypeClasses, TypeOperators, KindSignatures #-} {-# 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 indices = ixList (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." -- TODO: deferred type error checks disabled for now, because unfortunately, they are -- fragile to test for throughout different GHC versions 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 ] ] ixset-typed-0.5/tests/0000755000000000000000000000000007346545000013170 5ustar0000000000000000ixset-typed-0.5/tests/TestIxSetTyped.hs0000644000000000000000000000017107346545000016425 0ustar0000000000000000module Main where import Test.Tasty import Data.IxSet.Typed.Tests (allTests) main :: IO () main = defaultMain allTests