diff --git a/happstack-ixset.cabal b/happstack-ixset.cabal --- a/happstack-ixset.cabal +++ b/happstack-ixset.cabal @@ -1,7 +1,13 @@ Name: happstack-ixset -Version: 0.5.0.3 +Version: 6.0.0 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 diff --git a/src/Happstack/Data/IxSet.hs b/src/Happstack/Data/IxSet.hs --- a/src/Happstack/Data/IxSet.hs +++ b/src/Happstack/Data/IxSet.hs @@ -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, @@ -146,8 +139,11 @@ getGTE, getRange, groupBy, - getOrd, + -- * Index creation helpers + flatten, + flattenWithCalcs, + -- * Debugging and optimisation stats ) @@ -158,7 +154,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 +170,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 +248,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 +308,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 +358,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 +371,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 +461,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 +470,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 +489,6 @@ 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' - -- | 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 +502,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,17 +635,17 @@ -- 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 (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 --query impl function @@ -561,7 +654,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 +663,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 +702,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] diff --git a/src/Happstack/Data/IxSet/Ix.hs b/src/Happstack/Data/IxSet/Ix.hs --- a/src/Happstack/Data/IxSet/Ix.hs +++ b/src/Happstack/Data/IxSet/Ix.hs @@ -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 diff --git a/tests/Happstack/Data/IxSet/Tests.hs b/tests/Happstack/Data/IxSet/Tests.hs --- a/tests/Happstack/Data/IxSet/Tests.hs +++ b/tests/Happstack/Data/IxSet/Tests.hs @@ -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"]