diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,3 @@ #!/usr/bin/env runhaskell import Distribution.Simple -main = defaultMainWithHooks defaultUserHooks +main = defaultMainWithHooks simpleUserHooks 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.2.1 +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 @@ -9,8 +15,13 @@ homepage: http://happstack.com Category: Web, Distributed Computing Build-Type: Simple -Cabal-Version: >= 1.2.3 +Cabal-Version: >= 1.6 +source-repository head + type: darcs + subdir: happstack-ixset + location: http://patch-tag.com/r/mae/happstack + flag base4 Flag tests @@ -23,20 +34,25 @@ else Build-Depends: base < 4 + if impl(ghc >= 6.12.1) + Build-Depends: syb-with-class >= 0.6.1 + else + Build-Depends: syb-with-class < 0.6.1 + + Build-Depends: containers, - happstack-data >= 0.2.1 && < 0.3, - happstack-util >= 0.2.1 && < 0.3, - mtl, - syb-with-class, + happstack-data >= 6.0 && < 6.1, + happstack-util >= 6.0 && < 6.1, + mtl >= 1.1 && < 2.1, template-haskell hs-source-dirs: src if flag(tests) hs-source-dirs: tests + Build-Depends: QuickCheck >= 2 && <3, HUnit Exposed-modules: Happstack.Data.IxSet Happstack.Data.IxSet.Ix - Happstack.Data.IxSet.Usage if flag(tests) Exposed-modules: Happstack.Data.IxSet.Tests @@ -49,15 +65,18 @@ -- 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 Main-Is: Test.hs GHC-Options: -threaded - Build-depends: HUnit hs-source-dirs: tests, src if flag(tests) Buildable: True + Build-Depends: QuickCheck >= 2 && <3, HUnit else Buildable: False 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 @@ -1,101 +1,163 @@ {-# LANGUAGE UndecidableInstances, OverlappingInstances, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, RankNTypes, FunctionalDependencies, DeriveDataTypeable, - GADTs, CPP #-} - + 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@ - -1. Decide what parts of your type you want indexed, and - make your type an instance of Indexable +> 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 - @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 @ +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: -3. Use insert,delete,replace and empty to build up an IxSet collection +> 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 +> ] - @entries = foldr insert empty [e1,e2,e3,e4]@ - @entries' = foldr delete entries [e1,e3]@ - @entries'' = update e4 e5 entries@ +3. Use 'insert', 'delete', 'updateIx', 'deleteIx' and 'empty' to build + 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 the only the first author +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 +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@ - @getFirstAuthor = let Just (Author a)=gGet Entry in FirstAuthor a@ +> 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 - @instance Indexable Entry ([Word],FirstAuthor) - ... - empty = .... - Ix (Map.empty::Map FirstAuthor (Set Entry))] - calcs entry = (getWords Entry,getFirstAuthor entry) +-} - entries \@= (FirstAuthor \"john\@doe.com\") -- guess what this does@ +module Happstack.Data.IxSet + ( + -- * Set type + IxSet, + Indexable(..), + noCalcs, + inferIxSet, + ixSet, + ixFun, + ixGen, + + -- * Changes to set + IndexOp, + change, + insert, + delete, + updateIx, + deleteIx, --} + -- * Creation + fromSet, + fromList, -module Happstack.Data.IxSet (module Happstack.Data.IxSet, - module Ix) - where + -- * 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, + + -- * Index creation helpers + flatten, + flattenWithCalcs, + + -- * Debugging and optimisation + stats +) +where + import qualified Happstack.Data.IxSet.Ix as Ix import Happstack.Data.IxSet.Ix (Ix(Ix)) -import Data.Generics hiding (GT) -import Data.Dynamic +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 @@ -108,347 +170,570 @@ import Happstack.Util.TH import Happstack.Data import qualified Data.Generics.SYB.WithClass.Basics as SYBWC +import Prelude hiding (null) -- the core datatypes -data IxSet a = ISet [a] | IxSet [Ix a] +-- | Set with associatex indexes. +data IxSet a = IxSet [Ix a] deriving (Data, Typeable) +-- | 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 _:_) = + case cast b of + Just b' -> a==b' + 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 (ISet x) = z ISet `f` x - toConstr _ (ISet _) = iSetConstr + gfoldl _ f z ixset = z fromList `f` toList ixset toConstr _ (IxSet _) = ixSetConstr gunfold _ k z c = case SYBWC.constrIndex c of - 1 -> k (z ISet) - 2 -> k (z fromList) - _ -> error "unexpected match" + 1 -> k (z fromList) + _ -> error "IxSet.SYBWC.Data.gunfold unexpected match" dataTypeOf _ _ = ixSetDataType -iSetConstr :: SYBWC.Constr -iSetConstr = SYBWC.mkConstr ixSetDataType "ISet" [] SYBWC.Prefix ixSetConstr :: SYBWC.Constr ixSetConstr = SYBWC.mkConstr ixSetDataType "IxSet" [] SYBWC.Prefix ixSetDataType :: SYBWC.DataType -ixSetDataType = SYBWC.mkDataType "IxSet" [iSetConstr, ixSetConstr] +ixSetDataType = SYBWC.mkDataType "IxSet" [ixSetConstr] -instance (Indexable a b, Data a, Ord a, Default a) => Default (IxSet a) where - defaultValue = ISet [] +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 -{- | empty defines what an empty IxSet for this particular type should look - like. - calcs adds indexable values not found in the type. - If you don't want calculated values use Indexable a (). +{- | 'Indexable' class defines objects that can be members of 'IxSet'. -} -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 + -- indexes. Use 'ixSet' function to create the set and fill it in + -- with 'ixFun' and 'ixGen'. empty :: IxSet a - 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. + +> data Foo = Foo Int String + +and + +> $(inferIxSet "FooDB" ''Foo 'noCalcs [''Int,''String]) + +will build a type synonym + +> type FooDB = IxSet Foo + +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', '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" inferIxSet ixset typeName calName entryPoints = do calInfo <- reify calName typeInfo <- reify typeName - let (context,names) = case typeInfo of + let (context,binders) = case typeInfo of TyConI (DataD ctxt _ nms _ _) -> (ctxt,nms) TyConI (NewtypeD ctxt _ nms _ _) -> (ctxt,nms) TyConI (TySynD _ nms _) -> ([],nms) - _ -> error "unexpected match" - typeCon = foldl appT (conT typeName) (map varT names) + _ -> 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,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: " ++ pprint t') - mkEntryPoint n = appE (conE 'Ix) (sigE (varE 'Map.empty) (forallT names (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)) + 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) + 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) |] + empty = ixSet $(listE (map mkEntryPoint entryPoints)) + |] let ixType = appT (conT ''IxSet) typeCon - ixType' <- tySynD (mkName ixset) names ixType + ixType' <- tySynD (mkName ixset) binders ixType return $ [i, ixType'] -- ++ d - _ -> error "unexpected match" + _ -> error "IxSet.inferIxSet calInfo unexpected match" --- modification operations +#if MIN_VERSION_template_haskell(2,4,0) +tyVarBndrToName :: TyVarBndr -> Name +tyVarBndrToName (PlainTV nm) = nm +tyVarBndrToName (KindedTV nm _) = nm +#else +tyVarBndrToName :: a -> a +tyVarBndrToName = id +#endif --- | Generically traverses the argument and converts all data in it to Dynamic --- and returns all the iternal data as a list of Dynamic -flatten :: (Typeable a, Data a) => a -> [Dynamic] -flatten x = case cast x of - Just y -> [toDyn (y :: String)] - Nothing -> toDyn x : concat (gmapQ flatten x) + +-- modification operations + type IndexOp = forall k a. (Ord k,Ord a) => k -> a -> Map k (Set a) -> Map k (Set a) --- | Higher order operator for modifying IxSets. Use this when your final --- function should have the form a->IxSet a->IxSet a, e.g. insert. -change :: (Data a, Ord a,Data b,Indexable a b) => +-- | 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) + +-- | 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 :: (Typeable a,Indexable a,Ord a) => IndexOp -> a -> IxSet a -> IxSet a -change op x (ISet as) = change op x $ fromList as -change op x (IxSet indices) = - IxSet $ update indices $ flatten (x,calcs x) +change op x (IxSet indexes) = + IxSet v where - update [] _ = [] - update _ [] = [] - update (Ix index:is) dyns = Ix index':update is dyns' + 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,dyns') = partition (\d->dynTypeRep d == keyType) dyns - -- partition handles out of order indexes - ii dkey = op (fromJust $ fromDynamic dkey) x - index' = foldr ii index ds -- handle multiple values - update _ _ = error "unexpected match" + 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 " ++ showTypeOf key ++ " of " ++ showTypeOf x + else List.foldl' ii index ds -- handle multiple values --- | Inserts an item into the IxSet -insert :: (Data a, Ord a,Data b,Indexable a b) => a -> IxSet a -> IxSet a +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 :: (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 +-- | Removes an item from the 'IxSet'. +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. -updateIx :: (Indexable a b, Ord a, Data a, Typeable k) +-- | 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, Ord a, Typeable a, Typeable k) => k -> a -> IxSet a -> IxSet a updateIx i new ixset = insert new $ maybe ixset (flip delete ixset) $ getOne $ ixset @= i +-- | 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, Ord a, Typeable a, Typeable k) + => k -> IxSet a -> IxSet a +deleteIx i ixset = maybe ixset (flip delete ixset) $ + getOne $ ixset @= i + -- conversion operations --- | Converts an IxSet to a Set of its elements +-- | Converts an 'IxSet' to a 'Set' of its elements. toSet :: Ord a => IxSet a -> Set a -toSet (IxSet (Ix ix:_)) = Map.fold Set.union Set.empty ix +toSet (IxSet (Ix ix _:_)) = List.foldl' Set.union Set.empty (Map.elems ix) toSet (IxSet []) = Set.empty -toSet (ISet lst) = Set.fromList lst -toSet _ = error "unexpected match" --- | Takes a list of Ixs 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 -toSet' _ = error "unexpected match" - --- | 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 - --- | 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 +-- | Converts a 'Set' to an 'IxSet'. +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 +-- | Converts a list to an 'IxSet'. +fromList :: (Indexable a, Ord a, Typeable a) => [a] -> IxSet a +fromList list = insertList list empty --- | Returns the number of unique items in the IxSet +-- | Returns the number of unique items in the 'IxSet'. size :: Ord a => IxSet a -> Int size = Set.size . toSet --- | Converts an IxSet to its list of elements. +-- | Converts an 'IxSet' to its list of elements. toList :: Ord a => IxSet a -> [a] toList = Set.toList . toSet --- | Converts a list of Ix's -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])]) --- | If the IxSet is a singleton it will return the one item stored, else Nothing. +-- | 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 getOne ixset = case toList ixset of [x] -> Just x _ -> Nothing --- | getOne with a user provided default +-- | Like 'getOne' with a user provided default. getOneOr :: Ord a => a -> IxSet a -> a getOneOr def = fromMaybe def . getOne +-- | Return 'True' if the 'IxSet' is empty, 'False' otherwise. +null :: IxSet a -> Bool +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 +-- | An infix 'intersection' operation. +(&&&) :: (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 +-- | An infix 'union' operation. +(|||) :: (Ord a, Typeable a, Indexable a) => IxSet a -> IxSet a -> IxSet a (|||) = union infixr 5 &&& infixr 5 ||| --- | Takes the union of the two IxSets -union :: (Ord a, Data a, Indexable a b) => IxSet a -> IxSet a -> IxSet a -union x1 x2 = fromSet $ Set.union (toSet x1) (toSet x2) +-- | Takes the union of the two 'IxSet's. +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 IxSets -intersection :: (Ord a, Data a, Indexable a b) => IxSet a -> IxSet a -> IxSet a -intersection x1 x2 = fromSet $ Set.intersection (toSet x1) (toSet x2) +-- | Takes the intersection of the two 'IxSet's. +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 +-- | Infix version of 'getEQ'. +(@=) :: (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 +-- | Infix version of 'getLT'. +(@<) :: (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 +-- | Infix version of 'getGT'. +(@>) :: (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 +-- | Infix version of 'getLTE'. +(@<=) :: (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 +-- | Infix version of 'getGTE'. +(@>=) :: (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. --- It is possible to provide a key of a type not indexed in the IxSet. In --- this case the function returns the empty IxSet for this type. -getEQ :: (Indexable a b, Data a, Ord a, Typeable k) +-- | 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, 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. --- It is possible to provide a key of a type not indexed in the IxSet. In --- this case the function returns the empty IxSet for this type. -getLT :: (Indexable a b, Data a, Ord a, Typeable k) +-- | 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, 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. --- It is possible to provide a key of a type not indexed in the IxSet. In --- this case the function returns the empty IxSet for this type. -getGT :: (Indexable a b, Data a, Ord a, Typeable k) +-- The set must be indexed over key type, doing otherwise results in +-- runtime error. +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. --- It is possible to provide a key of a type not indexed in the IxSet. In --- this case the function returns the empty IxSet for this type. -getLTE :: (Indexable a b, Data a, Ord a, Typeable k) +-- | 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, Typeable a, Ord a, Typeable k) => k -> IxSet a -> IxSet a -getLTE v ix = let ix2 = (getLT v ix) in union ix2 $ getEQ v ix +getLTE = getOrd2 True True False --- | Returns the subset with an index greater than or equal to the provided key. --- It is possible to provide a key of a type not indexed in the IxSet. In --- this case the function returns the empty IxSet for this type. -getGTE :: (Indexable a b, Data a, Ord a, Typeable k) +-- | 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, Typeable a, Ord a, Typeable k) => k -> IxSet a -> IxSet a -getGTE v ix = let ix2 = (getOrd GT v ix) in union ix2 $ getEQ v ix +getGTE = getOrd2 False True True -- | Returns the subset with an index within the interval provided. --- The top of the interval is closed and the bottom is open. --- It is possible to provide a key of a type not indexed in the IxSet. In --- this case the function returns the empty IxSet for this type. -getRange :: (Indexable a b, Typeable k, Ord a, Data a) +-- 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, Typeable k, Ord a, Typeable a) => k -> k -> IxSet a -> IxSet a -getRange k1 k2 ixset = intersection (getGTE k1 ixset) (getLT k2 ixset) +getRange k1 k2 ixset = getGTE k1 (getLT k2 ixset) --- | Returns lists of elements paired with the indices determined by type --- inference. -groupBy::(Typeable k,Typeable t) => IxSet t -> [(k, [t])] -groupBy (IxSet indices) = collect indices +-- | Returns lists of elements paired with the indexes determined by +-- type inference. +groupBy :: (Typeable k,Typeable t) => IxSet t -> [(k, [t])] +groupBy (IxSet indexes) = collect indexes where - collect [] = [] - collect (Ix index:is) = maybe (collect is) f (fromDynamic $ toDyn index) - collect _ = error "unexpected match" + collect [] = [] -- FIXME: should be an error + collect (Ix index _:is) = maybe (collect is) f (cast index) f = mapSnd Set.toList . Map.toList -groupBy _ = error "unexpected match" --- | A reversed groupBy -rGroupBy :: (Typeable k, Typeable t) => IxSet t -> [(k, [t])] -rGroupBy = reverse . groupBy +-- | 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 --- | A function for building up selectors on IxSets. Used in the various get* --- functions. -getOrd :: (Indexable a b, Ord a, Data a, Typeable k) + +-- | 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 a, Ord a, Typeable a, Typeable k) => Ordering -> k -> IxSet a -> IxSet a -getOrd ord v (IxSet indices) = collect indices +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 :: (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 - v' = toDyn v - collect [] = empty - collect (Ix index:is) = maybe (collect is) f $ fromDynamic 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 $ - case ord of - LT -> lt - GT -> gt - EQ -> eq + f v'' = insertMapOfSets result empty where - (lt',eq',gt')=Map.splitLookup v'' index - lt = concatMap (Set.toList . snd) $ Map.toList lt' - gt = concatMap (Set.toList . snd) $ Map.toList gt' - eq = maybe [] Set.toList eq' - collect _ = error "unexpected match" -getOrd _ _ _ = error "unexpected match" - ---we want a gGets that returns a list of all matches + (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 lt' + else Map.empty + gt = if incgt + then gt' + else Map.empty + eq = if inceq + then eq' + else Nothing {-- Optimization todo: @@ -458,15 +743,26 @@ * nicer operators? -* good way to enforce that you don't query on the wrong type? - * nice way to do updates that doesn't involve reinserting the entire data * can we index on xpath rather than just type? --} -instance (Show a,Indexable a b,Data a,Ord a) => Monoid (IxSet a) where - mempty=empty +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 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 indexes) = (no_elements,no_indexes,no_keys,no_values) + where + 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 @@ -2,26 +2,42 @@ MultiParamTypeClasses, TemplateHaskell, PolymorphicComponents, DeriveDataTypeable,ExistentialQuantification #-} -module Happstack.Data.IxSet.Ix where +{- | +This module defines typable indices and convenience functions. Should +be probably considered private to 'Happstack.Data.IxSet'. + +-} +module Happstack.Data.IxSet.Ix + ( 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 Happstack.Data +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 -data Ix a = IxDefault | - forall key . (Typeable key, Ord key) => Ix (Map key (Set a)) +-- | '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)) (a -> [key]) deriving Typeable -- minimal hacky instance instance Data a => Data (Ix a) where - toConstr (Ix _) = con_Ix_Data - toConstr _ = error "unexpected match for: toConstr" + toConstr (Ix _ _) = con_Ix_Data gunfold _ _ = error "gunfold" dataTypeOf _ = ixType_Data @@ -31,39 +47,54 @@ ixType_Data :: DataType ixType_Data = mkDataType "Happstack.Data.IxSet.Ix" [con_Ix_Data] - -instance Default a => Default (Ix a) where - defaultValue = IxDefault - -ixDefaultConstr :: SYBWC.Constr -ixDefaultConstr = SYBWC.mkConstr ixDataType "IxDefault" [] SYBWC.Prefix ixConstr :: SYBWC.Constr ixConstr = SYBWC.mkConstr ixDataType "Ix" [] SYBWC.Prefix ixDataType :: SYBWC.DataType -ixDataType = SYBWC.mkDataType "Ix" [ixDefaultConstr, ixConstr] +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 _ IxDefault = ixDefaultConstr - toConstr _ (Ix _) = ixConstr + toConstr _ (Ix _ _) = ixConstr gunfold = error "gunfold Ix" dataTypeOf _ _ = ixDataType -- modification operations --- | Convenience function for inserting into Maps of Sets --- as in the case of an Ix. If they key did not already exist in the Map, then a new Set is added transparently. +-- | 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.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 Maps of Sets --- If the resulting Set is empty, then the entry is removed from the Map +-- | 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) 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 = 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/src/Happstack/Data/IxSet/Usage.hs b/src/Happstack/Data/IxSet/Usage.hs deleted file mode 100644 --- a/src/Happstack/Data/IxSet/Usage.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE UndecidableInstances, OverlappingInstances, FlexibleInstances - ,MultiParamTypeClasses, TemplateHaskell, DeriveDataTypeable, - TypeSynonymInstances #-} - --- XXX This modules should be turned into documentation and/or test cases - -module Happstack.Data.IxSet.Usage where - -import Happstack.Data.IxSet - -import Data.Generics hiding (GT) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) - -{-- -HOW TO USE ---} - ---define your datatype -data Test = Test String Int deriving (Data,Typeable,Eq,Ord,Show,Read) - ---define the db on the datatype ---should be able to do template haskell to generate these - - -instance Indexable Test String where - empty = IxSet [Ix (Map.empty :: Map String (Set Test)), - Ix (Map.empty :: Map Int (Set Test))] - calcs (Test s _) = s ++ "bar" - -t1, t2, t3 :: Test -t1 = Test "foo" 2 -t2 = Test "foo" 3 -t3 = Test "goo" 3 - -c1, c2, c3, c4 :: IxSet Test -c1 = insert t1 empty -c2 = insert t2 c1 -c3 = delete t1 c2 -c4 = insert t3 c2 - -s1, s2, s3, s4, s5, s6, s7, s8 :: IxSet Test -s1 = getEQ "foo" c4 -s2 = getEQ (3::Int) c4 -s3 = getLT (4::Int) c4 -s4 = getGT (2::Int) c4 -s5 = getRange "foo" "goo" c4 -s6 = getLT (4::Int) s5 -s7 = union s6 s4 -s8 = getEQ "foobar" c4 - 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 @@ -1,55 +1,289 @@ - -{-# LANGUAGE TemplateHaskell, OverlappingInstances, UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell, OverlappingInstances, + UndecidableInstances, TemplateHaskell #-} {-# OPTIONS_GHC -fglasgow-exts #-} -- Check that the SYBWC Data instance for IxSet works, by testing -- that going to and from XML works. -module Happstack.Data.IxSet.Tests (allTests, ixSet001) where +module Happstack.Data.IxSet.Tests where import Control.Monad -import Data.Generics.SYB.WithClass.Basics -import Data.Maybe import Happstack.Data -import Happstack.Data.IxSet +import Happstack.Data.IxSet as IxSet import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) -import Test.HUnit (Test,(~:),(@=?)) +import qualified Data.Set as Set +import Test.HUnit (Test,(~:),(@=?), test) +import Control.Exception as E +import Test.QuickCheck +import Happstack.Util.Testing +import Data.Data as Data +import Data.Maybe $( deriveAll [''Eq, ''Ord, ''Default, ''Show] [d| data Foo = Foo String Int + data FooX = Foo1 String Int + | Foo2 Int + + data NoIdxFoo = NoIdxFoo Int + data BadlyIndexed = BadlyIndexed Int + + 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 + |] ) +$(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]) + +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) +-} -t1, t2, t3 :: Foo -t1 = Foo "foo" 2 -t2 = Foo "foo" 3 -t3 = Foo "goo" 3 +$(inferIxSet "Foos" ''Foo 'fooCalcs [''String, ''Int]) -ts :: [Foo] -ts = [t1, t2, t3] +instance Indexable S where + empty = ixSet [ ixFun (\(S x) -> [length x]) + ] + -- calcs _ = () -ixset :: IxSet Foo -ixset = fromList ts -xml :: [Element] -xml = toXml ixset -ixset' :: Maybe (IxSet Foo) -ixset' = fromXml Rigid xml +ixSetCheckMethodsOnDefault :: Test +ixSetCheckMethodsOnDefault = test + [ "size is zero" ~: 0 @=? + size (defaultValue :: Foos) + , "getOne returns Nothing" ~: + Nothing @=? getOne (defaultValue :: Foos) + , "getOneOr returns default" ~: + Foo1 "" 44 @=? getOneOr (Foo1 "" 44) defaultValue + , "toList returns []" ~: + [] @=? toList (defaultValue :: Foos) + ] -ts' :: Maybe [Foo] -ts' = fmap toList ixset' +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 -ixSet001 :: Test -ixSet001 = "ixSet001" ~: (Just ts) @=? ts' +foox_set_abc :: FooXs +foox_set_abc = insert foox_a $ insert foox_b $ insert foox_c $ defaultValue +foox_set_cde :: FooXs +foox_set_cde = insert foox_e $ insert foox_d $ insert foox_c $ defaultValue +ixSetCheckSetMethods :: Test +ixSetCheckSetMethods = test + [ "size abc is 3" ~: 3 @=? + size foox_set_abc + , "size cde is 3" ~: 3 @=? + size foox_set_cde + , "getOne returns Nothing" ~: + Nothing @=? getOne foox_set_abc + , "getOneOr returns default" ~: + Foo1 "" 44 @=? getOneOr (Foo1 "" 44) foox_set_abc + , "toList returns 3 element list" ~: + 3 @=? length (toList foox_set_abc) + ] + +isError :: a -> IO Bool +isError x = (x `seq` return False) `E.catch` \(ErrorCall _) -> return True + +badIndexSafeguard :: Test +badIndexSafeguard = test + [ "check if there is error when no first index on value" ~: + isError (size $ insert (BadlyIndexed 123) empty) + , "check if indexing with missing index" ~: + isError (getOne (foox_set_cde @= True)) + ] + +testTriple :: Test +testTriple = test + [ "check if we can find element" ~: + 1 @=? size ((insert (Triple 1 2 3) empty) + @= (1::Int) @= (2::Int)) + ] + + +instance Arbitrary Foo where + arbitrary = liftM2 Foo arbitrary arbitrary + +instance (Arbitrary a,Data.Data a, Ord a, Indexable a) => + Arbitrary (IxSet a) where + arbitrary = liftM fromList arbitrary + +prop_toAndFromXml :: Foos -> Bool +prop_toAndFromXml ixset = Just ixset == ixset' + where + xml :: [Element] + xml = toXml ixset + + ixset' :: Maybe (IxSet Foo) + ixset' = fromXml Rigid xml + +prop_sizeEqToListLength :: Foos -> Bool +prop_sizeEqToListLength ixset = size ixset == length (toList ixset) + +prop_union :: Foos -> Foos -> Bool +prop_union ixset1 ixset2 = + toSet (ixset1 `union` ixset2) == toSet ixset1 `Set.union` toSet ixset2 + +prop_intersection :: Foos -> Foos -> Bool +prop_intersection ixset1 ixset2 = + toSet (ixset1 `intersection` ixset2) == + toSet ixset1 `Set.intersection` toSet ixset2 + +prop_opers :: Foos -> Int -> Bool +prop_opers ixset intidx = + ((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) + where + eq = ixset @= intidx + lt = ixset @< intidx + gt = ixset @> intidx + lteq = ixset @<= intidx + gteq = ixset @>= intidx + +prop_sureelem :: Foos -> Foo -> Bool +prop_sureelem ixset foo@(Foo string intidx) = + not (IxSet.null eq) && + not (IxSet.null lteq) && + not (IxSet.null gteq) + where + ixset' = insert foo ixset + eq = ixset' @= intidx + lteq = ixset' @<= intidx + gteq = ixset' @>= intidx + +prop_ranges :: Foos -> Int -> Int -> Bool +prop_ranges ixset intidx1 intidx2 = + ((ixset @>< (intidx1,intidx2)) == (gt1 &&& lt2)) && + ((ixset @>=< (intidx1,intidx2)) == ((gt1 ||| eq1) &&& lt2)) && + ((ixset @><= (intidx1,intidx2)) == (gt1 &&& (lt2 ||| eq2))) && + ((ixset @>=<= (intidx1,intidx2)) == ((gt1 ||| eq1) &&& (lt2 ||| eq2))) + where + eq1 = ixset @= intidx1 + lt1 = ixset @< intidx1 + gt1 = ixset @> intidx1 + eq2 = ixset @= intidx2 + lt2 = ixset @< intidx2 + gt2 = ixset @> intidx2 + + +prop_any :: Foos -> [Int] -> Bool +prop_any ixset idxs = + (ixset @+ idxs) == foldr union empty (map ((@=) ixset) idxs) + +prop_all :: Foos -> [Int] -> Bool +prop_all ixset idxs = + (ixset @* idxs) == foldr intersection 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" ~: [ixSet001] +allTests = "happstack-ixset" ~: [ ixSetCheckMethodsOnDefault + , ixSetCheckSetMethods + , badIndexSafeguard + , test (True @=? findElement 1 1) + , testTriple + , funIndexes + , qctest prop_toAndFromXml + , qctest prop_sizeEqToListLength + , qctest prop_union + , qctest prop_intersection + , qctest prop_opers + , qctest prop_sureelem + , qctest prop_ranges + , qctest prop_any + , qctest prop_all + ] + + + +bigSet :: Int -> MultiIndexed +bigSet n = fromList $ + [ MultiIndex string int integer maybe_int either_bool_char | + string <- ["abc", "def", "ghi", "jkl"], + int <- [1..n], + integer <- [10000..10010], + maybe_int <- [Nothing, Just 5, Just 6], + either_bool_char <- [Left True, Left False, Right 'A', Right 'B']] ++ + [ MultiIndexSubset int bool string | + string <- ["abc", "def", "ghi"], + int <- [1..n], + bool <- [True, False]] + + +{- +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"] + @>=<= (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 + +{- +bigSetTests :: Test +bigSetTests = "bigSetTests" ~: return (findElement 1 1) +-}