happstack-ixset 0.2.1 → 6.0.1
raw patch · 6 files changed
Files
- Setup.hs +1/−1
- happstack-ixset.cabal +29/−10
- src/Happstack/Data/IxSet.hs +555/−259
- src/Happstack/Data/IxSet/Ix.hs +55/−24
- src/Happstack/Data/IxSet/Usage.hs +0/−52
- tests/Happstack/Data/IxSet/Tests.hs +261/−27
Setup.hs view
@@ -1,3 +1,3 @@ #!/usr/bin/env runhaskell import Distribution.Simple-main = defaultMainWithHooks defaultUserHooks+main = defaultMainWithHooks simpleUserHooks
happstack-ixset.cabal view
@@ -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
src/Happstack/Data/IxSet.hs view
@@ -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]
src/Happstack/Data/IxSet/Ix.hs view
@@ -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
− src/Happstack/Data/IxSet/Usage.hs
@@ -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-
tests/Happstack/Data/IxSet/Tests.hs view
@@ -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)+-}