happstack-ixset 0.5.0.3 → 6.0.1
raw patch · 4 files changed
Files
- happstack-ixset.cabal +15/−7
- src/Happstack/Data/IxSet.hs +350/−208
- src/Happstack/Data/IxSet/Ix.hs +37/−10
- tests/Happstack/Data/IxSet/Tests.hs +62/−5
happstack-ixset.cabal view
@@ -1,7 +1,13 @@ Name: happstack-ixset-Version: 0.5.0.3+Version: 6.0.1 Synopsis: Efficient relational queries on Haskell sets. -Description: Just pick which parts of your data structures you want indexed using an easy to use template-haskell function. Spare yourself the need to write, run, and maintain code that marshalls your data to/from an external relational database just for efficient queries. happstack-ixset relies on generics and TH to spare you the boilerplate normally required for such tasks. +Description: + Just pick which parts of your data structures you want indexed+ using an easy to use template-haskell function. Spare yourself the+ need to write, run, and maintain code that marshalls your data+ to/from an external relational database just for efficient+ queries. happstack-ixset relies on generics and TH to spare you+ the boilerplate normally required for such tasks. License: BSD3 License-file: COPYING Author: Happstack team, HAppS LLC@@ -14,7 +20,7 @@ source-repository head type: darcs subdir: happstack-ixset- location: http://patch-tag.com/r/mae/happstack/pullrepo+ location: http://patch-tag.com/r/mae/happstack flag base4 @@ -35,10 +41,9 @@ Build-Depends: containers,- happstack-data >= 0.5 && < 0.6,- happstack-util >= 0.5 && < 0.6,+ happstack-data >= 6.0 && < 6.1,+ happstack-util >= 6.0 && < 6.1, mtl >= 1.1 && < 2.1,- syb-with-class, template-haskell hs-source-dirs: src@@ -60,7 +65,10 @@ -- Should have ", DeriveDataTypeable", but Cabal complains cpp-options: -DUNIX- ghc-options: -Wall+ if impl(ghc >= 6.12)+ ghc-options: -Wall -fno-warn-unused-do-bind+ else+ ghc-options: -Wall GHC-Prof-Options: -auto-all Executable happstack-ixset-tests
src/Happstack/Data/IxSet.hs view
@@ -3,101 +3,94 @@ FunctionalDependencies, DeriveDataTypeable, GADTs, CPP, ScopedTypeVariables #-} - {- |-Description:- An efficient implementation of queryable sets. Assume you have a type like: - @data Entry = Entry Author [Author] Updated Id Content- newtype Updated = Updated EpochTime- newtype Id = Id Int64- newtype Content = Content String- newtype Author = Author Email- type Email = String@+> data Entry = Entry Author [Author] Updated Id Content+> newtype Updated = Updated EpochTime+> newtype Id = Id Int64+> newtype Content = Content String+> newtype Author = Author Email+> type Email = String -1. Decide what parts of your type you want indexed and- make your type an instance of Indexable+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: - @instance Indexable Entry () where- empty = ixSet - [ Ix (Map.empty::Map Author (Set Entry)) -- out of order- , Ix (Map.empty::Map Id (Set Entry))- , Ix (Map.empty::Map Updated (Set Entry))- , Ix (Map.empty::Map Test (Set Entry)) -- bogus index- , Ix (Map.empty::Map Word (Set Entry)) -- text index- ]- calcs entry = () -- words for text indexing purposes @+> instance Indexable Entry where+> empty = ixSet +> [ ixGen (Proxy :: Proxy Author) -- out of order+> , ixGen (Proxy :: Proxy Id)+> , ixGen (Proxy :: Proxy Updated)+> , ixGen (Proxy :: Proxy Test) -- bogus index+> ] 3. Use 'insert', 'delete', 'updateIx', 'deleteIx' and 'empty' to build- up an 'IxSet' collection-- @entries = foldr insert empty [e1,e2,e3,e4]@- @entries' = foldr delete entries [e1,e3]@- @entries'' = update e4 e5 entries@+ up an 'IxSet' collection: -4. Use the query functions below to grab data from it. e.g.+> entries = foldr insert empty [e1,e2,e3,e4]+> entries' = foldr delete entries [e1,e3]+> entries'' = update e4 e5 entries - @entries \@< (Updated t1) \@= (Author \"john\@doe.com\")@+4. Use the query functions below to grab data from it: - will find all items in entries updated earlier than @t1@ by- @john\@doe.com@.+> entries @= (Author "john@doe.com") @< (Updated t1) -5. Text Index+Statement above will find all items in entries updated earlier than+@t1@ by @john\@doe.com@. -If you want to do add a text index extract the words in entry and pass-them in the 'calc' method of the 'Indexable' class. Then if you want-all entries with either word1 or word2, you change the instance to+5. Text index - @getWords entry = let Just (Content s) =- gGet entry in map Word $ words s@+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: - @instance Indexable Entry [Word] where- ....- calcs entry = getWords entry@+> getWords (Entry _ _ _ _ (Content s)) = map Word $ words s+>+> instance Indexable Entry where+> empty = ixSet [ ...+> ixFun getWords+> ] -Now you can do this query to find entries with any of the words+Now you can do this query to find entries with any of the words: - @entries \@+ [Word \"word1\",Word \"word2\"]@+> entries @+ [Word "word1", Word "word2"] And if you want all entries with both: - @entries \@* [Word \"word1\",Word \"word2\"]@+> entries @* [Word "word1", Word "word2"] 6. Find only the first author -If an Entry has multiple authors and you want to be able to query-on the first author, define a @FirstAuthor@ datatype and add it to the-result of calc. calc @e = (toWords e, getFirstAuthor e)@ and now you can-do-- @newtype FirstAuthor = FirstAuthor Email@- - @getFirstAuthor = let Just (Author a) = - gGet Entry in FirstAuthor a@-- @instance Indexable Entry ([Word],FirstAuthor)- ...- empty = ....- Ix (Map.empty::Map FirstAuthor (Set Entry))]- calcs entry = (getWords Entry,getFirstAuthor entry)+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: - entries \@= (FirstAuthor \"john\@doe.com\") -- guess what this does@+> newtype FirstAuthor = FirstAuthor Email+> +> getFirstAuthor (Entry author _ _ _ _) = [FirstAuthor author]+>+> instance Indexable Entry where+> ...+> empty = ixSet [ ...+> ixFun getFirstAuthor+> ]+>+> entries @= (FirstAuthor "john@doe.com") -- guess what this does -} module Happstack.Data.IxSet (- module Ix,- -- * Set type IxSet, Indexable(..), noCalcs, inferIxSet, ixSet,+ ixFun,+ ixGen, -- * Changes to set IndexOp,@@ -114,6 +107,8 @@ -- * Conversion toSet, toList,+ toAscList,+ toDescList, getOne, getOneOr, @@ -146,8 +141,13 @@ getGTE, getRange, groupBy,- getOrd,+ groupAscBy,+ groupDescBy, + -- * Index creation helpers+ flatten,+ flattenWithCalcs,+ -- * Debugging and optimisation stats )@@ -158,7 +158,6 @@ import Data.Generics (Data, gmapQ) import Data.Maybe import Data.Monoid-import Data.List (partition) import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map@@ -175,33 +174,71 @@ -- the core datatypes +-- | Set with associatex indexes. data IxSet a = IxSet [Ix a] deriving (Data, Typeable) --- | Create an 'IxSet' using list of indices. Useful in 'Indexable'--- 'empty' method.+-- | Create an 'IxSet' using a list of indexes. Useful in 'Indexable'+-- 'empty' method. Use 'ixFun' and 'ixGen' as list elements.+--+-- > instance Indexable Type where+-- > empty = ixSet [ ...+-- > ixFun getIndex1+-- > ixGen (Proxy :: Proxy Index2Type)+-- > ]+--+-- First index in the list must contain all objects in set, doing+-- otherwise result in runtime error. ixSet :: [Ix a] -> IxSet a ixSet = IxSet +-- | Create a functional index. Provided function should return a list+-- of indexes where value should be found. +--+-- > getIndexes value = [...indexes...]+--+-- > instance Indexable Type where+-- > empty = ixSet [ ixFun getIndexes ]+--+-- This is the recommended way to create indexes.+ixFun :: forall a b . (Ord b,Typeable b) => (a -> [b]) -> Ix a+ixFun f = Ix Map.empty f+++-- | Create a generic index. Provided example is used only as type+-- source so you may use a 'Proxy'. The 'ixGen' uses flatten to+-- traverse value using its 'Data' instance.+--+-- > instance Indexable Type where+-- > empty = ixSet [ ixGen (Proxy :: Proxy Type) ]+--+-- In production systems consider using 'ixFun' in place of 'ixGen' as+-- the former one is much faster.+ixGen :: forall a b . (Data a,Ord b,Typeable b) => Proxy b -> Ix a+ixGen _example = ixFun (flatten :: a -> [b])++showTypeOf :: (Typeable a) => a -> String+showTypeOf x = showsPrec 11 (typeOf x) []+ instance (Eq a,Ord a,Typeable a) => Eq (IxSet a) where- IxSet (Ix a:_) == IxSet (Ix b:_) = + IxSet (Ix a _:_) == IxSet (Ix b _:_) = case cast b of Just b' -> a==b'- Nothing -> error "trying to compare two sets with different types of first indices, this is a bug in library"- _ == _ = error "comparing sets without indices, this is a bug in library"+ Nothing -> error "trying to compare two sets with different types of first indexes, this is a bug in the library"+ _ == _ = error "comparing sets without indexes, this is a bug in the library" instance (Eq a,Ord a,Typeable a) => Ord (IxSet a) where compare a b = compare (toSet a) (toSet b) instance Version (IxSet a)-instance (Serialize a, Ord a, Data a, Indexable a b) => Serialize (IxSet a) where+instance (Serialize a, Ord a, Typeable a, Indexable a) => Serialize (IxSet a) where putCopy = contain . safePut . toList getCopy = contain $ liftM fromList safeGet instance (SYBWC.Data ctx a, SYBWC.Sat (ctx (IxSet a)), SYBWC.Sat (ctx [a]),- Indexable a b, Data a, Ord a)+ Indexable a, Data a, Ord a) => SYBWC.Data ctx (IxSet a) where- gfoldl _ f z (IxSet x) = z fromList `f` toList' x+ 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)@@ -215,56 +252,52 @@ -instance (Indexable a b, Data a, Ord a, Default a) => Default (IxSet a) where+instance (Indexable a, Ord a,Data a, Default a) => Default (IxSet a) where defaultValue = empty -instance (Ord a,Show a) => Show (IxSet a) where show = show . toSet+instance (Ord a,Show a) => Show (IxSet a) where + showsPrec prec = showsPrec prec . toSet -instance (Ord a,Read a,Data a,Indexable a b) => Read (IxSet a) where+instance (Ord a,Read a,Typeable a,Indexable a) => Read (IxSet a) where readsPrec n = mapFst fromSet . readsPrec n {- | 'Indexable' class defines objects that can be members of 'IxSet'. - If you don't want calculated values use @'Indexable' a ()@. -}-class (Data b) => Indexable a b | a -> b where+class Indexable a where -- | Method 'empty' defines what an empty 'IxSet' for this -- particular type should look like. It should have all necessary- -- indices. Use 'ixSet' function to create the set.+ -- indexes. Use 'ixSet' function to create the set and fill it in+ -- with 'ixFun' and 'ixGen'. empty :: IxSet a- -- | Method 'calcs' adds indexable values not found in the- -- type. Those end up in indices just like other types found in- -- objects. If you don't want any calculated values just use- -- 'noCalcs'.- calcs :: a -> b- --should this be a fromDyn so we can provide a default impl? --- | Function to be used for 'calcs' in the case of an @'Indexable' a ()@--- instance.+-- | Function to be used for 'calcs' 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.+'Indexable' instance from a data type, e.g. - @data Foo = Foo Int String@ +> data Foo = Foo Int String - and+and - @$(inferIxSet \"FooDB\" ''Foo 'noCalcs [''Int,''String])@ +> $(inferIxSet "FooDB" ''Foo 'noCalcs [''Int,''String]) - will build a type synonym +will build a type synonym - @type FooDB = IxSet Foo@ +> type FooDB = IxSet Foo - with @Int@ and @String@ as indices.+with @Int@ and @String@ as indexes. - WARNING: The type specified as the first index must be a type which- appears in all values in the 'IxSet' or 'toList' and 'toSet' will- not function properly. You will be warned not to do this by runtime error.- You can always use the element type itself. For example:- - @$(inferIxSet \"FooDB\" ''Foo 'noCalcs [''Foo, ''Int, ''String])@+WARNING: The type specified as the first index must be a type which+appears in all values in the 'IxSet' or 'toList', 'toSet' and+serialization will not function properly. You will be warned not to do+this by runtime error. You can always use the element type+itself. For example: +> $(inferIxSet "FooDB" ''Foo 'noCalcs [''Foo, ''Int, ''String])+ -} inferIxSet :: String -> TH.Name -> TH.Name -> [TH.Name] -> Q [Dec] inferIxSet _ _ _ [] = error "inferIxSet needs at least one index"@@ -279,20 +312,35 @@ names = map tyVarBndrToName binders - typeCon = foldl appT (conT typeName) (map varT names)+ typeCon = List.foldl' appT (conT typeName) (map varT names)+#if MIN_VERSION_template_haskell(2,4,0)+ mkCtx = classP+#else+ -- mkType :: Name -> [TypeQ] -> TypeQ+ mkType con = foldl appT (conT con)++ mkCtx = mkType+#endif+ dataCtxConQ = [mkCtx ''Data [varT name] | name <- names]+ fullContext = do+ dataCtxCon <- sequence dataCtxConQ+ return (context ++ dataCtxCon) case calInfo of VarI _ t _ _ -> 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 = appE (conE 'Ix) (sigE (varE 'Map.empty) (forallT binders (return context) $- appT (appT (conT ''Map) (conT n)) (appT (conT ''Set) typeCon)))- in do i <- instanceD' (return context) (appT (appT (conT ''Indexable) typeCon) (return calType))+ 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)+ in do i <- instanceD' (fullContext) + (conT ''Indexable `appT` typeCon) [d| empty :: IxSet a empty = ixSet $(listE (map mkEntryPoint entryPoints))- calcs :: a -> b- calcs = $(varE calName) |]+ |] let ixType = appT (conT ''IxSet) typeCon ixType' <- tySynD (mkName ixset) binders ixType return $ [i, ixType'] -- ++ d@@ -314,8 +362,8 @@ type IndexOp = forall k a. (Ord k,Ord a) => k -> a -> Map k (Set a) -> Map k (Set a) --- | Generically traverses the argument and converts all data in it to--- 'Dynamic' and returns all the internal data as a list of 'Dynamic'.+-- | 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]@@ -327,39 +375,88 @@ 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)+ -- | Higher order operator for modifying 'IxSet's. Use this when your--- final function should have the form @a -> IxSet a -> IxSet a@,+-- final function should have the form @a -> 'IxSet' a -> 'IxSet' a@, -- e.g. 'insert' or 'delete'.-change :: (Data a, Ord a,Data b,Indexable a b) =>+change :: (Typeable a,Indexable a,Ord a) => IndexOp -> a -> IxSet a -> IxSet a-change op x (IxSet indices) = +change op x (IxSet indexes) = IxSet v where- v = zipWith update (True:repeat False) indices- a = (x,calcs x)- update firstindex (Ix index) = Ix index'+ v = zipWith update (True:repeat False) indexes+ update firstindex (Ix index flatten2) = Ix index' flatten2 where- keyType = typeOf ((undefined :: Map key (Set a) -> key) index)- ds = flatten a- ii dkey = op dkey x+ key = (undefined :: Map key (Set a) -> key) index+ ds = flatten2 x+ ii m dkey = op dkey x m index' = if firstindex && List.null ds- then error $ "Happstack.Data.IxSet.change: all values must appear in first declared index " ++ show keyType ++ " of " ++ show (typeOf x)- else foldr ii index ds -- handle multiple values+ then error $ "Happstack.Data.IxSet.change: all values must appear in first declared index " ++ showTypeOf key ++ " of " ++ showTypeOf x+ else List.foldl' ii index ds -- handle multiple values +insertList :: (Typeable a,Indexable a,Ord a) + => [a] -> IxSet a -> IxSet a+insertList xs (IxSet indexes) = + IxSet v+ where+ v = zipWith update (True:repeat False) indexes+ update firstindex (Ix index flatten2) = Ix index' flatten2+ where+ key = (undefined :: Map key (Set a) -> key) index+ flattencheck x+ | firstindex = case flatten2 x of+ [] -> error $ "Happstack.Data.IxSet.change: all values must appear in first declared index " ++ showTypeOf key ++ " of " ++ showTypeOf x+ res -> res+ | otherwise = flatten2 x+ dss = [(k,x) | x <- xs, k <- flattencheck x]+ index' = Ix.insertList dss index++insertMapOfSets :: (Typeable a, Ord a,Indexable a,Typeable key,Ord key) + => Map key (Set a) -> IxSet a -> IxSet a+insertMapOfSets originalindex (IxSet indexes) = + IxSet v+ where+ v = map update indexes+ xs = concatMap Set.toList (Map.elems originalindex)+ update (Ix index flatten2) = Ix index' flatten2+ where+ dss = [(k,x) | x <- xs, k <- flatten2 x]+ {- We try to be really clever here. The originalindex 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 index we+ could reuse originalindex as it is. But there can be more, so we need to+ add remaining ones. Anyway we try to reuse old structure and keep + new allocations low as much as possible.+ -}+ index' = case cast originalindex of+ Just originalindex' -> + let dssf = filter (\(k,_v) -> not (Map.member k originalindex')) dss+ in Ix.insertList dssf originalindex'+ Nothing -> Ix.insertList dss index+ -- | Inserts an item into the 'IxSet'. If your data happens to have -- primary key this function might not be what you want. See -- 'updateIx'.-insert :: (Data a, Ord a,Data b,Indexable a b) => a -> IxSet a -> IxSet a+insert :: (Typeable a, Ord a,Indexable a) => a -> IxSet a -> IxSet a insert = change Ix.insert -- | Removes an item from the 'IxSet'.-delete :: (Data a, Ord a,Data b,Indexable a b) => a -> IxSet a -> IxSet a+delete :: (Typeable a, Ord a,Indexable a) => a -> IxSet a -> IxSet a delete = change Ix.delete -- | Will replace the item with index k. Only works if there is at -- most one item with that index in the 'IxSet'. Will not change -- 'IxSet' if you have more then 1 item with given index.-updateIx :: (Indexable a b, Ord a, Data a, Typeable k)+updateIx :: (Indexable a, Ord a, Typeable a, Typeable k) => k -> a -> IxSet a -> IxSet a updateIx i new ixset = insert new $ maybe ixset (flip delete ixset) $@@ -368,7 +465,7 @@ -- | Will delete the item with index k. Only works if there is at -- most one item with that index in the 'IxSet'. Will not change -- 'IxSet' if you have more then 1 item with given index.-deleteIx :: (Indexable a b, Ord a, Data a, Typeable k)+deleteIx :: (Indexable a, Ord a, Typeable a, Typeable k) => k -> IxSet a -> IxSet a deleteIx i ixset = maybe ixset (flip delete ixset) $ getOne $ ixset @= i@@ -377,24 +474,16 @@ -- | Converts an 'IxSet' to a 'Set' of its elements. toSet :: Ord a => IxSet a -> Set a-toSet (IxSet idxs) = toSet' idxs---- | Takes a list of 'Ix's and converts it into a 'Set'.-toSet' :: Ord a => [Ix a] -> Set a-toSet' (Ix ix:_) = Map.fold Set.union Set.empty ix-toSet' [] = Set.empty---- | Converts a 'Set' to an 'IxSet'.-fromSet :: (Indexable a b, Ord a, Data a) => Set a -> IxSet a-fromSet set = Set.fold insert empty set+toSet (IxSet (Ix ix _:_)) = List.foldl' Set.union Set.empty (Map.elems ix)+toSet (IxSet []) = Set.empty -- | Converts a 'Set' to an 'IxSet'.-fromSet' :: (Indexable a b, Ord a, Data a) => Set a -> IxSet a-fromSet' set = Set.fold insert empty set+fromSet :: (Indexable a, Ord a, Typeable a) => Set a -> IxSet a+fromSet = fromList . Set.toList -- | Converts a list to an 'IxSet'.-fromList :: (Indexable a b, Ord a, Data a) => [a] -> IxSet a-fromList = fromSet . Set.fromList+fromList :: (Indexable a, Ord a, Typeable a) => [a] -> IxSet a+fromList list = insertList list empty -- | Returns the number of unique items in the 'IxSet'. size :: Ord a => IxSet a -> Int@@ -404,10 +493,22 @@ toList :: Ord a => IxSet a -> [a] toList = Set.toList . toSet --- | Converts a list of 'Ix's to list of elements. -toList' :: Ord a => [Ix a] -> [a]-toList' = Set.toList . toSet'+-- | Converts an 'IxSet' to its list of elements.+--+-- List will be sorted in ascending order by the index 'k'.+--+-- The list may contain duplicate entries if a single value produces multiple keys.+toAscList :: forall k a. (Indexable a, Typeable a, Typeable k) => Proxy k -> IxSet a -> [a]+toAscList _ ixset = concatMap snd (groupAscBy ixset :: [(k, [a])]) +-- | Converts an 'IxSet' to its list of elements.+--+-- List will be sorted in descending order by the index 'k'.+--+-- The list may contain duplicate entries if a single value produces multiple keys.+toDescList :: forall k a. (Indexable a, Typeable a, Typeable k) => Proxy k -> IxSet a -> [a]+toDescList _ ixset = concatMap snd (groupDescBy ixset :: [(k, [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 a -> Maybe a@@ -421,120 +522,132 @@ -- | Return 'True' if the 'IxSet' is empty, 'False' otherwise. null :: IxSet a -> Bool-null (IxSet (Ix ix:_)) = Map.null ix-null (IxSet []) = True+null (IxSet (Ix ix _:_)) = Map.null ix+null (IxSet []) = True -- set operations -- | An infix 'intersection' operation.-(&&&) :: (Ord a, Data a, Indexable a b) => IxSet a -> IxSet a -> IxSet a+(&&&) :: (Ord a, Typeable a, Indexable a) => IxSet a -> IxSet a -> IxSet a (&&&) = intersection -- | An infix 'union' operation.-(|||) :: (Ord a, Data a, Indexable a b) => IxSet a -> IxSet a -> IxSet a+(|||) :: (Ord a, Typeable a, Indexable a) => IxSet a -> IxSet a -> IxSet a (|||) = union infixr 5 &&& infixr 5 ||| -- | Takes the union of the two 'IxSet's.-union :: (Ord a, Data a, Indexable a b) => IxSet a -> IxSet a -> IxSet a-union x1 x2 = fromSet $ Set.union (toSet x1) (toSet x2)+union :: (Ord a, Typeable a, Indexable a) => IxSet a -> IxSet a -> IxSet a+union (IxSet x1) (IxSet x2) = IxSet indexes'+ where+ indexes' = zipWith union' x1 x2+ union' (Ix a f) (Ix b _) = + case cast b of+ Nothing -> error "IxSet.union: indexes out of order"+ Just b' -> Ix (Ix.union a b') f -- | Takes the intersection of the two 'IxSet's.-intersection :: (Ord a, Data a, Indexable a b) => IxSet a -> IxSet a -> IxSet a-intersection x1 x2 = fromSet $ Set.intersection (toSet x1) (toSet x2)+intersection :: (Ord a, Typeable a, Indexable a) => IxSet a -> IxSet a -> IxSet a+intersection (IxSet x1) (IxSet x2) = IxSet indexes'+ where+ indexes' = zipWith intersection' x1 x2+ intersection' (Ix a f) (Ix b _) = + case cast b of+ Nothing -> error "IxSet.intersection: indexes out of order"+ Just b' -> Ix (Ix.intersection a b') f -- query operators -- | Infix version of 'getEQ'.-(@=) :: (Indexable a b, Data a, Ord a, Typeable k)- => IxSet a -> k -> IxSet a+(@=) :: (Indexable a, Typeable a, Ord a, Typeable k)+ => IxSet a -> k -> IxSet a ix @= v = getEQ v ix -- | Infix version of 'getLT'.-(@<) :: (Indexable a b, Data a, Ord a, Typeable k)- => IxSet a -> k -> IxSet a+(@<) :: (Indexable a, Typeable a, Ord a, Typeable k)+ => IxSet a -> k -> IxSet a ix @< v = getLT v ix -- | Infix version of 'getGT'.-(@>) :: (Indexable a b, Data a, Ord a, Typeable k)- => IxSet a -> k -> IxSet a+(@>) :: (Indexable a, Typeable a, Ord a, Typeable k)+ => IxSet a -> k -> IxSet a ix @> v = getGT v ix -- | Infix version of 'getLTE'.-(@<=) :: (Indexable a b, Data a, Ord a, Typeable k)- => IxSet a -> k -> IxSet a+(@<=) :: (Indexable a, Typeable a, Ord a, Typeable k)+ => IxSet a -> k -> IxSet a ix @<= v = getLTE v ix -- | Infix version of 'getGTE'.-(@>=) :: (Indexable a b, Data a, Ord a, Typeable k)- => IxSet a -> k -> IxSet a+(@>=) :: (Indexable a, Typeable a, Ord a, Typeable k)+ => IxSet a -> k -> IxSet a ix @>= v = getGTE v ix --- | Returns the subset with indices in the open interval (k,k).-(@><) :: (Indexable a b, Data a, Ord a, Typeable k)- => IxSet a -> (k, k) -> IxSet a+-- | Returns the subset with indexes in the open interval (k,k).+(@><) :: (Indexable a, Typeable a, Ord a, Typeable k)+ => IxSet a -> (k, k) -> IxSet a ix @>< (v1,v2) = getLT v2 $ getGT v1 ix --- | Returns the subset with indices in [k,k).-(@>=<) :: (Indexable a b, Data a, Ord a, Typeable k)- => IxSet a -> (k, k) -> IxSet a+-- | Returns the subset with indexes in [k,k).+(@>=<) :: (Indexable a, Typeable a, Ord a, Typeable k)+ => IxSet a -> (k, k) -> IxSet a ix @>=< (v1,v2) = getLT v2 $ getGTE v1 ix --- | Returns the subset with indices in (k,k].-(@><=) :: (Indexable a b, Data a, Ord a, Typeable k)- => IxSet a -> (k, k) -> IxSet a+-- | Returns the subset with indexes in (k,k].+(@><=) :: (Indexable a, Typeable a, Ord a, Typeable k)+ => IxSet a -> (k, k) -> IxSet a ix @><= (v1,v2) = getLTE v2 $ getGT v1 ix --- | Returns the subset with indices in [k,k].-(@>=<=) :: (Indexable a b, Data a, Ord a, Typeable k)- => IxSet a -> (k, k) -> IxSet a+-- | Returns the subset with indexes in [k,k].+(@>=<=) :: (Indexable a, Typeable a, Ord a, Typeable k)+ => IxSet a -> (k, k) -> IxSet a ix @>=<= (v1,v2) = getLTE v2 $ getGTE v1 ix -- | Creates the subset that has an index in the provided list.-(@+) :: (Indexable a b, Data a, Ord a, Typeable k)- => IxSet a -> [k] -> IxSet a-ix @+ list = foldr union empty $ map (ix @=) list+(@+) :: (Indexable a, Typeable a, Ord a, Typeable k)+ => IxSet a -> [k] -> IxSet a+ix @+ list = List.foldl' union empty $ map (ix @=) list --- | Creates the subset that matches all the provided indices.-(@*) :: (Indexable a b, Data a, Ord a, Typeable k)- => IxSet a -> [k] -> IxSet a-ix @* list = foldr intersection empty $ map (ix @=) list+-- | Creates the subset that matches all the provided indexes.+(@*) :: (Indexable a, Typeable a, Ord a, Typeable k)+ => IxSet a -> [k] -> IxSet 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 a b, Data a, Ord a, Typeable k)+getEQ :: (Indexable a, Typeable a, Ord a, Typeable k) => k -> IxSet a -> IxSet 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 a b, Data a, Ord a, Typeable k)+getLT :: (Indexable a, Typeable a, Ord a, Typeable k) => k -> IxSet a -> IxSet 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 a b, Data a, Ord a, Typeable k)+getGT :: (Indexable a, Typeable a, Ord a, Typeable k) => k -> IxSet a -> IxSet 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 a b, Data a, Ord a, Typeable k)+getLTE :: (Indexable a, Typeable a, Ord a, Typeable k) => k -> IxSet a -> IxSet 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 a b, Data a, Ord a, Typeable k)+getGTE :: (Indexable a, Typeable a, Ord a, Typeable k) => k -> IxSet a -> IxSet a getGTE = getOrd2 False True True @@ -542,18 +655,45 @@ -- 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 a b, Typeable k, Ord a, Data a)+getRange :: (Indexable a, Typeable k, Ord a, Typeable a) => k -> k -> IxSet a -> IxSet a getRange k1 k2 ixset = getGTE k1 (getLT k2 ixset) --- | Returns lists of elements paired with the indices determined by+-- | Returns lists of elements paired with the indexes determined by -- type inference.-groupBy::(Typeable k,Typeable t) => IxSet t -> [(k, [t])]-groupBy (IxSet indices) = collect indices+groupBy :: (Typeable k,Typeable t) => IxSet t -> [(k, [t])]+groupBy (IxSet indexes) = collect indexes where- collect [] = []- collect (Ix index:is) = maybe (collect is) f (cast index)+ collect [] = [] -- FIXME: should be an error+ collect (Ix index _:is) = maybe (collect is) f (cast index) f = mapSnd Set.toList . Map.toList++-- | Returns lists of elements paired with the indexes determined by+-- type inference.+--+-- The resulting list will be sorted in ascending order by 'k'.+-- The values in '[t]' will be sorted in ascending order as well.+groupAscBy :: (Typeable k,Typeable t) => IxSet t -> [(k, [t])]+groupAscBy (IxSet indexes) = collect indexes+ where+ collect [] = [] -- FIXME: should be an error+ collect (Ix index _:is) = maybe (collect is) f (cast index)+ f = mapSnd Set.toAscList . Map.toAscList++-- | Returns lists of elements paired with the indexes determined by+-- type inference.+--+-- The resulting list will be sorted in descending order by 'k'.+-- +-- NOTE: The values in '[t]' 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 '[t]'.+groupDescBy :: (Typeable k,Typeable t) => IxSet t -> [(k, [t])]+groupDescBy (IxSet indexes) = collect indexes+ where+ collect [] = [] -- FIXME: should be an error+ collect (Ix index _:is) = maybe (collect is) f (cast index)+ f = mapSnd Set.toAscList . Map.toDescList --query impl function @@ -561,7 +701,7 @@ -- various get* functions. The set must be indexed over key type, -- doing otherwise results in runtime error. -getOrd :: (Indexable a b, Ord a, Data a, Typeable k)+getOrd :: (Indexable a, Ord a, Typeable a, Typeable k) => Ordering -> k -> IxSet a -> IxSet a getOrd LT = getOrd2 True False False getOrd EQ = getOrd2 False True False@@ -570,28 +710,30 @@ -- | 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 :: (Indexable a b, Ord a, Data a, Typeable k)- => Bool -> Bool -> Bool -> k -> IxSet a -> IxSet a-getOrd2 inclt inceq incgt v ixset@(IxSet indices) = collect indices+getOrd2 :: (Indexable a, Ord a, Typeable a, Typeable k)+ => Bool -> Bool -> Bool -> k -> IxSet a -> IxSet a+getOrd2 inclt inceq incgt v ixset@(IxSet indexes) = collect indexes where- collect [] = error $ "IxSet: there is no index " ++ show (typeOf v) ++ - " in " ++ show (typeOf ixset)- collect (Ix index:is) = maybe (collect is) f $ cast v+ collect [] = error $ "IxSet: there is no index " ++ showTypeOf v ++ + " in " ++ showTypeOf ixset+ collect (Ix index _:is) = maybe (collect is) f $ cast v where- f v'' = foldr insert empty (lt ++ eq ++ gt)+ f v'' = insertMapOfSets result empty where (lt',eq',gt') = Map.splitLookup v'' index+ ltgt = Map.unionWith Set.union lt gt+ result = case eq of+ Just eqset -> Map.insertWith Set.union v'' eqset ltgt+ Nothing -> ltgt lt = if inclt - then concatMap Set.toList $ Map.elems lt'- else []+ then lt'+ else Map.empty gt = if incgt - then concatMap Set.toList $ Map.elems gt'- else []+ then gt'+ else Map.empty eq = if inceq- then maybe [] Set.toList eq'- else []----we want a gGets that returns a list of all matches+ then eq'+ else Nothing {-- Optimization todo:@@ -607,20 +749,20 @@ --} -instance (Indexable a b, Data a, Ord a) => Monoid (IxSet a) where+instance (Indexable a, Typeable a, Ord a) => Monoid (IxSet a) where mempty = empty mappend = union -- | 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+-- declared indexes 3. number of keys in all indexes 4. number of+-- values in all keys in all indexes. This can aid you in debugging -- and optimisation. stats :: (Ord a) => IxSet a -> (Int,Int,Int,Int)-stats (IxSet indices) = (no_elements,no_indices,no_keys,no_values)+stats (IxSet indexes) = (no_elements,no_indexes,no_keys,no_values) where- no_elements = size (IxSet indices)- no_indices = length indices- no_keys = sum [Map.size m | Ix m <- indices]- no_values = sum [sum [Set.size s | s <- Map.elems m] | Ix m <- indices]+ no_elements = size (IxSet indexes)+ no_indexes = length indexes+ no_keys = sum [Map.size m | Ix m _ <- indexes]+ no_values = sum [sum [Set.size s | s <- Map.elems m] | Ix m _ <- indexes]
src/Happstack/Data/IxSet/Ix.hs view
@@ -12,26 +12,32 @@ ( Ix(..) , insert , delete+ , insertList+ , deleteList+ , union+ , intersection ) where import Data.Generics hiding (GT)-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Set (Set)-import qualified Data.Set as Set+import Data.List (foldl')+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set import qualified Data.Generics.SYB.WithClass.Basics as SYBWC -- the core datatypes --- | 'Ix' is a 'Map' from some 'Typeable' key to a set of values for+-- | 'Ix' is a 'Map' from some 'Typeable' key to a 'Set' of values for -- that key. 'Ix' carries type information inside.-data Ix a = forall key . (Typeable key, Ord key) => Ix (Map key (Set a))+data Ix a = forall key . (Typeable key, Ord key) => + Ix (Map key (Set a)) (a -> [key]) deriving Typeable -- minimal hacky instance instance Data a => Data (Ix a) where- toConstr (Ix _) = con_Ix_Data+ toConstr (Ix _ _) = con_Ix_Data gunfold _ _ = error "gunfold" dataTypeOf _ = ixType_Data @@ -49,7 +55,7 @@ instance (SYBWC.Data ctx a, SYBWC.Sat (ctx (Ix a))) => SYBWC.Data ctx (Ix a) where gfoldl = error "gfoldl Ix"- toConstr _ (Ix _) = ixConstr+ toConstr _ (Ix _ _) = ixConstr gunfold = error "gunfold Ix" dataTypeOf _ _ = ixDataType @@ -60,9 +66,14 @@ -- '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 --- | Convenience function for deleting from 'Map's of 'Set's If the+-- | 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 = foldl' (\m (k,v)-> insert k v m) index 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)@@ -70,4 +81,20 @@ 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 = foldl' (\m (k,v) -> delete k v m) index xs++-- | Take 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++-- | Take 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
tests/Happstack/Data/IxSet/Tests.hs view
@@ -32,6 +32,10 @@ data MultiIndex = MultiIndex String Int Integer (Maybe Int) (Either Bool Char) | MultiIndexSubset Int Bool String+ data Triple = Triple Int Int Int+ data S = S String+ data G a b = G a b+ |] ) @@ -43,15 +47,33 @@ $(inferIxSet "MultiIndexed" ''MultiIndex 'noCalcs [''String, ''Int, ''Integer, ''Bool, ''Char]) +$(inferIxSet "Triples" ''Triple 'noCalcs [''Int])++fooCalcs (Foo s _) = s ++ "bar"++++$(inferIxSet "Gs" ''G 'noCalcs [''Int])++++{- instance Indexable Foo String where- empty = ixSet [Ix (Map.empty :: Map String (Set Foo)),- Ix (Map.empty :: Map Int (Set Foo))]- calcs (Foo s _) = s ++ "bar"+ empty = ixSet [ -- Ix (Map.empty :: Map String (Set Foo)) flattenWithCalcs+ ixGenWithCalcs (undefined :: String)+ , -- Ix (Map.empty :: Map Int (Set Foo)) flattenWithCalcs+ ixGenWithCalcs (undefined :: Int)+-} -type Foos = IxSet Foo+$(inferIxSet "Foos" ''Foo 'fooCalcs [''String, ''Int]) +instance Indexable S where+ empty = ixSet [ ixFun (\(S x) -> [length x])+ ]+ -- calcs _ = () + ixSetCheckMethodsOnDefault :: Test ixSetCheckMethodsOnDefault = test [ "size is zero" ~: 0 @=? @@ -105,12 +127,18 @@ isError (getOne (foox_set_cde @= True)) ] +testTriple :: Test+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 b) => +instance (Arbitrary a,Data.Data a, Ord a, Indexable a) => Arbitrary (IxSet a) where arbitrary = liftM fromList arbitrary @@ -182,11 +210,26 @@ prop_all ixset idxs = (ixset @* idxs) == foldr intersection empty (map ((@=) ixset) idxs) +funSet :: IxSet S+funSet = IxSet.fromList [S "", S "abc", S "def", S "abcde"]++funIndexes :: Test+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 = "happstack-ixset" ~: [ ixSetCheckMethodsOnDefault , ixSetCheckSetMethods , badIndexSafeguard , test (True @=? findElement 1 1)+ , testTriple+ , funIndexes , qctest prop_toAndFromXml , qctest prop_sizeEqToListLength , qctest prop_union@@ -212,6 +255,20 @@ string <- ["abc", "def", "ghi"], int <- [1..n], bool <- [True, False]]+++{-+GHCi++let b = bigSet 100+to evaluate things+size b++timed $ findElementX b 1++2010-05-09 6:00 daje 50s++-} findElementX :: MultiIndexed -> Int -> Bool findElementX set n = isJust $ getOne (set @+ ["abc","def","ghi"]