happstack-ixset 0.4.1 → 0.5.0
raw patch · 6 files changed
+508/−256 lines, 6 filesdep +QuickCheckdep ~happstack-datadep ~happstack-utilsetup-changed
Dependencies added: QuickCheck
Dependency ranges changed: happstack-data, happstack-util
Files
- Setup.hs +1/−1
- happstack-ixset.cabal +5/−5
- src/Happstack/Data/IxSet.hs +279/−156
- src/Happstack/Data/IxSet/Ix.hs +21/−17
- src/Happstack/Data/IxSet/Usage.hs +0/−52
- tests/Happstack/Data/IxSet/Tests.hs +202/−25
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,5 +1,5 @@ Name: happstack-ixset-Version: 0.4.1+Version: 0.5.0 Synopsis: Efficient relational queries on Haskell sets. Description: Just pick which parts of your data structures you want indexed using an easy to use template-haskell function. Spare yourself the need to write, run, and maintain code that marshalls your data to/from an external relational database just for efficient queries. happstack-ixset relies on generics and TH to spare you the boilerplate normally required for such tasks. License: BSD3@@ -35,8 +35,8 @@ Build-Depends: containers,- happstack-data >= 0.4.1 && < 0.5,- happstack-util >= 0.4.1 && < 0.5,+ happstack-data >= 0.5 && < 0.6,+ happstack-util >= 0.5 && < 0.6, mtl, syb-with-class, template-haskell@@ -44,10 +44,10 @@ 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@@ -66,7 +66,7 @@ Executable happstack-ixset-tests Main-Is: Test.hs GHC-Options: -threaded- Build-depends: HUnit+ Build-Depends: QuickCheck >= 2 && <3, HUnit hs-source-dirs: tests, src if flag(tests) Buildable: True
src/Happstack/Data/IxSet.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE UndecidableInstances, OverlappingInstances, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, RankNTypes, FunctionalDependencies, DeriveDataTypeable,- GADTs, CPP #-}+ GADTs, CPP, ScopedTypeVariables #-} {- |@@ -18,20 +18,21 @@ newtype Author = Author Email type Email = String@ -1. Decide what parts of your type you want indexed, and+1. Decide what parts of your type you want indexed and make your type an instance of Indexable @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+ 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 @ -3. Use insert,delete,replace and empty to build up an IxSet collection+3. Use 'insert', 'delete', 'updateIx', 'deleteIx' and 'empty' to build+ up an 'IxSet' collection @entries = foldr insert empty [e1,e2,e3,e4]@ @entries' = foldr delete entries [e1,e3]@@@ -41,17 +42,17 @@ @entries \@< (Updated t1) \@= (Author \"john\@doe.com\")@ - will find all items in entries updated earlier than t1 by- john\@doe.com.+ will find all items in entries updated earlier than @t1@ by+ @john\@doe.com@. 5. Text Index 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+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 @getWords entry = let Just (Content s) =- gGet entry in map Word $ words s@+ gGet entry in map Word $ words s@ @instance Indexable Entry [Word] where ....@@ -65,15 +66,17 @@ @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+on the first author, define a @FirstAuthor@ datatype and add it to the+result of calc. calc @e = (toWords e, getFirstAuthor e)@ and now you can do @newtype FirstAuthor = FirstAuthor Email@- @getFirstAuthor = let Just (Author a)=gGet Entry in FirstAuthor a@+ + @getFirstAuthor = let Just (Author a) = + gGet Entry in FirstAuthor a@ @instance Indexable Entry ([Word],FirstAuthor) ...@@ -85,14 +88,74 @@ -} -module Happstack.Data.IxSet (module Happstack.Data.IxSet,- module Ix)- where+module Happstack.Data.IxSet + (+ module Ix,+ + -- * Set type+ IxSet,+ Indexable(..),+ noCalcs,+ inferIxSet,+ ixSet,+ + -- * Changes to set+ IndexOp,+ change,+ insert,+ delete,+ updateIx,+ deleteIx, + -- * Creation+ fromSet,+ fromList,++ -- * Conversion+ toSet,+ toList,+ getOne,+ getOneOr,++ -- * Size checking+ size,+ null,++ -- * Set operations+ (&&&),+ (|||),+ union,+ intersection,++ -- * Indexing+ (@=),+ (@<),+ (@>),+ (@<=),+ (@>=),+ (@><),+ (@>=<),+ (@><=),+ (@>=<=),+ (@+),+ (@*),+ getEQ,+ getLT,+ getGT,+ getLTE,+ getGTE,+ getRange,+ groupBy,+ getOrd,++ -- * 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)@@ -108,12 +171,28 @@ 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]+data IxSet a = IxSet [Ix a] deriving (Data, Typeable) +-- | Create an 'IxSet' using list of indices. Useful in 'Indexable'+-- 'empty' method.+ixSet :: [Ix a] -> IxSet a+ixSet = IxSet++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 indices, this is a bug in library"+ _ == _ = error "comparing sets without indices, this is a bug in 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 putCopy = contain . safePut . toList@@ -123,60 +202,72 @@ Indexable a b, 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 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 []+ defaultValue = empty instance (Ord a,Show a) => Show (IxSet a) where show = show . toSet instance (Ord a,Read a,Data a,Indexable a b) => 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'. + If you don't want calculated values use @'Indexable' a ()@. -}-class (Data b) => Indexable a b | a->b where+class (Data b) => Indexable a b | a -> b where+ -- | Method 'empty' defines what an empty 'IxSet' for this+ -- particular type should look like. It should have all necessary+ -- indices. Use 'ixSet' function to create the set. empty :: IxSet a- calcs :: a->b+ -- | Method 'calcs' adds indexable values not found in the+ -- type. Those end up in indices just like other types found in+ -- objects. If you don't want any calculated values just use+ -- 'noCalcs'.+ calcs :: a -> b --should this be a fromDyn so we can provide a default impl? --- | Function to be used for calcs in the case of an Indexable a () instance+-- | Function to be used for 'calcs' in the case of an @'Indexable' a ()@+-- instance. noCalcs :: t -> () noCalcs _ = () -{- | 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.+{- | 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 indices.+ WARNING: The type specified as the first index must be a type which appears in all values in the 'IxSet' or 'toList' and 'toSet' will- not function properly. You can always use the element type- itself. For example, - @$(inferIxSet "FooDB" ''Foo 'noCalcs [''Foo, ''Int,''String])@+ 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@@ -184,7 +275,7 @@ TyConI (DataD ctxt _ nms _ _) -> (ctxt,nms) TyConI (NewtypeD ctxt _ nms _ _) -> (ctxt,nms) TyConI (TySynD _ nms _) -> ([],nms)- _ -> error "unexpected match"+ _ -> error "IxSet.inferIxSet typeInfo unexpected match" names = map tyVarBndrToName binders @@ -194,23 +285,25 @@ let calType = getCalType t getCalType (ForallT _names _ t') = getCalType t' getCalType (AppT (AppT ArrowT _) t') = t'- getCalType t' = error ("Unexpected type: " ++ pprint t')+ getCalType t' = error ("Unexpected type in getCalType: " ++ pprint t') mkEntryPoint n = appE (conE 'Ix) (sigE (varE 'Map.empty) (forallT binders (return context) $ appT (appT (conT ''Map) (conT n)) (appT (conT ''Set) typeCon))) in do i <- instanceD' (return context) (appT (appT (conT ''Indexable) typeCon) (return calType)) [d| empty :: IxSet a- empty = IxSet $(listE (map mkEntryPoint entryPoints))+ empty = ixSet $(listE (map mkEntryPoint entryPoints)) calcs :: a -> b calcs = $(varE calName) |] let ixType = appT (conT ''IxSet) typeCon ixType' <- tySynD (mkName ixset) binders ixType return $ [i, ixType'] -- ++ d- _ -> error "unexpected match"+ _ -> error "IxSet.inferIxSet calInfo unexpected match" #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 @@ -218,172 +311,184 @@ -- modification operations --- | 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)- 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.+-- | Generically traverses the argument and converts all data in it to+-- 'Dynamic' and returns all the internal data as a list of 'Dynamic'.+--+-- 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)++-- | 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 :: (Data a, Ord a,Data b,Indexable a b) => 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 indices) = + IxSet v where- update [] _ = []- update _ [] = []- update (Ix index:is) dyns = Ix index':update is dyns'+ v = zipWith update (True:repeat False) indices+ a = (x,calcs x)+ update firstindex (Ix index) = Ix index' 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"+ ds = flatten a+ ii dkey = op dkey x+ index' = if firstindex && List.null ds+ then error $ "Happstack.Data.IxSet.change: all values must appear in first declared index " ++ show keyType ++ " of " ++ show (typeOf x)+ else foldr ii index ds -- handle multiple values --- | Inserts an item into the IxSet+-- | Inserts an item into the 'IxSet'. If your data happens to have+-- primary key this function might not be what you want. See+-- 'updateIx'. insert :: (Data a, Ord a,Data b,Indexable a b) => a -> IxSet a -> IxSet a insert = change Ix.insert --- | Removes an item from the IxSet+-- | Removes an item from the 'IxSet'. delete :: (Data a, Ord a,Data b,Indexable a b) => a -> IxSet a -> IxSet a delete = change Ix.delete --- | Will replace the item with index k. Only works if there is at most one--- item with that index in the IxSet.+-- | Will replace the item with index k. Only works if there is at+-- most one item with that index in the 'IxSet'. Will not change+-- 'IxSet' if you have more then 1 item with given index. updateIx :: (Indexable a b, Ord a, Data a, Typeable k) => 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 b, Ord a, Data 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 []) = Set.empty-toSet (ISet lst) = Set.fromList lst-toSet _ = error "unexpected match"+toSet (IxSet idxs) = toSet' idxs --- | Takes a list of Ixs and converts it into a Set+-- | Takes a list of 'Ix's and converts it into a 'Set'. toSet' :: Ord a => [Ix a] -> Set a toSet' (Ix ix:_) = Map.fold Set.union Set.empty ix toSet' [] = Set.empty-toSet' _ = error "unexpected match" --- | Converts a Set to an IxSet+-- | 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+-- | 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 list to an IxSet+-- | Converts a list to an 'IxSet'. fromList :: (Indexable a b, Ord a, Data a) => [a] -> IxSet a fromList = fromSet . Set.fromList --- | 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 +-- | Converts a list of 'Ix's to list of elements. toList' :: Ord a => [Ix a] -> [a] toList' = Set.toList . toSet' --- | If the IxSet is a singleton it will return the one item stored, else Nothing.+-- | 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.+-- | Return 'True' if the 'IxSet' is empty, 'False' otherwise. null :: IxSet a -> Bool null (IxSet (Ix ix:_)) = Map.null ix-null (ISet lst) = List.null lst null (IxSet []) = True-null _ = error "IxSet.null: unexpected match" -- set operations --- | An infix intersection operation+-- | An infix 'intersection' operation. (&&&) :: (Ord a, Data a, Indexable a b) => IxSet a -> IxSet a -> IxSet a (&&&) = intersection --- | An infix union operation+-- | An infix 'union' operation. (|||) :: (Ord a, Data a, Indexable a b) => IxSet a -> IxSet a -> IxSet a (|||) = union infixr 5 &&& infixr 5 ||| --- | Takes the union of the two IxSets+-- | Takes the union of the two 'IxSet's. union :: (Ord a, Data a, Indexable a b) => IxSet a -> IxSet a -> IxSet a union x1 x2 = fromSet $ Set.union (toSet x1) (toSet x2) --- | Takes the intersection of the two IxSets+-- | Takes the intersection of the two 'IxSet's. intersection :: (Ord a, Data a, Indexable a b) => IxSet a -> IxSet a -> IxSet a intersection x1 x2 = fromSet $ Set.intersection (toSet x1) (toSet x2) -- query operators --- | Infix version of getEQ+-- | Infix version of 'getEQ'. (@=) :: (Indexable a b, Data a, Ord a, Typeable k) => IxSet a -> k -> IxSet a ix @= v = getEQ v ix --- | Infix version of getLT+-- | Infix version of 'getLT'. (@<) :: (Indexable a b, Data a, Ord a, Typeable k) => IxSet a -> k -> IxSet a ix @< v = getLT v ix --- | Infix version of getGT+-- | Infix version of 'getGT'. (@>) :: (Indexable a b, Data a, Ord a, Typeable k) => IxSet a -> k -> IxSet a ix @> v = getGT v ix --- | Infix version of getLTE+-- | Infix version of 'getLTE'. (@<=) :: (Indexable a b, Data a, Ord a, Typeable k) => IxSet a -> k -> IxSet a ix @<= v = getLTE v ix --- | Infix version of getGTE+-- | Infix version of 'getGTE'. (@>=) :: (Indexable a b, Data 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)+-- | 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 ix @>< (v1,v2) = getLT v2 $ getGT v1 ix --- | Returns the subset with indices in [k,k)+-- | Returns the subset with indices in [k,k). (@>=<) :: (Indexable a b, Data 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]+-- | Returns the subset with indices in (k,k]. (@><=) :: (Indexable a b, Data 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]+-- | Returns the subset with indices in [k,k]. (@>=<=) :: (Indexable a b, Data a, Ord a, Typeable k) => IxSet a -> (k, k) -> IxSet a ix @>=<= (v1,v2) = getLTE v2 $ getGTE v1 ix@@ -398,87 +503,93 @@ => IxSet a -> [k] -> IxSet a ix @* list = foldr intersection empty $ 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.+-- | Returns the subset with an index equal to the provided key. The+-- set must be indexed over key type, doing otherwise results in+-- runtime error. getEQ :: (Indexable a b, Data a, Ord a, Typeable k) => 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.+-- | Returns the subset with an index less than the provided key. The+-- set must be indexed over key type, doing otherwise results in+-- runtime error. getLT :: (Indexable a b, Data a, Ord a, Typeable k) => 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.+-- The set must be indexed over key type, doing otherwise results in+-- runtime error. getGT :: (Indexable a b, Data 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.+-- | Returns the subset with an index less than or equal to the+-- provided key. The set must be indexed over key type, doing+-- otherwise results in runtime error. getLTE :: (Indexable a b, Data a, Ord a, Typeable k) => 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.+-- | Returns the subset with an index greater than or equal to the+-- provided key. The set must be indexed over key type, doing+-- otherwise results in runtime error. getGTE :: (Indexable a b, Data a, Ord a, Typeable k) => 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.+-- The bottom of the interval is closed and the top is open,+-- i. e. [k1;k2). The set must be indexed over key type, doing+-- otherwise results in runtime error. getRange :: (Indexable a b, Typeable k, Ord a, Data a) => 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.+-- | 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 where collect [] = []- collect (Ix index:is) = maybe (collect is) f (fromDynamic $ toDyn index)- collect _ = error "unexpected match"+ 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 --query impl function--- | A function for building up selectors on IxSets. Used in the various get*--- functions. ++-- | 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 b, Ord a, Data 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 b, Ord a, Data a, Typeable k)+ => Bool -> Bool -> Bool -> k -> IxSet a -> IxSet a+getOrd2 inclt inceq incgt v ixset@(IxSet indices) = collect indices where- v' = toDyn v- collect [] = empty- collect (Ix index:is) = maybe (collect is) f $ fromDynamic v'+ collect [] = error $ "IxSet: there is no index " ++ show (typeOf v) ++ + " in " ++ show (typeOf 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'' = foldr insert empty (lt ++ eq ++ gt) 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"+ (lt',eq',gt') = Map.splitLookup v'' index+ lt = if inclt + then concatMap Set.toList $ Map.elems lt'+ else []+ gt = if incgt + then concatMap Set.toList $ Map.elems gt'+ else []+ eq = if inceq+ then maybe [] Set.toList eq'+ else [] --we want a gGets that returns a list of all matches @@ -490,14 +601,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 b, Data a, Ord a) => Monoid (IxSet a) where+ mempty = empty mappend = union++-- | Statistics about 'IxSet'. This function returns quadruple+-- consisting of 1. total number of elements in the set 2. number of+-- declared indices 3. number of keys in all indices 4. number of+-- values in all keys in all indices. This can aid you in debugging+-- and optimisation.+stats :: (Ord a) => IxSet a -> (Int,Int,Int,Int)+stats (IxSet indices) = (no_elements,no_indices,no_keys,no_values)+ where+ no_elements = size (IxSet indices)+ no_indices = length indices+ no_keys = sum [Map.size m | Ix m <- indices]+ no_values = sum [sum [Set.size s | s <- Map.elems m] | Ix m <- indices]+
src/Happstack/Data/IxSet/Ix.hs view
@@ -2,26 +2,36 @@ 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+ ) + 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 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)) deriving Typeable -- minimal hacky instance instance Data a => Data (Ix a) where toConstr (Ix _) = con_Ix_Data- toConstr _ = error "unexpected match for: toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = ixType_Data @@ -31,35 +41,29 @@ 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 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 --- | Convenience function for deleting from Maps of Sets--- If the resulting Set is empty, then the entry is removed from the Map+-- | 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
− 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,232 @@--{-# 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 |] ) +$(inferIxSet "FooXs" ''FooX 'noCalcs [''Int, + ''String+ ])++$(inferIxSet "BadlyIndexeds" ''BadlyIndexed 'noCalcs [''String])++$(inferIxSet "MultiIndexed" ''MultiIndex 'noCalcs [''String, ''Int, ''Integer, ''Bool, ''Char])+ instance Indexable Foo String where- empty = IxSet [Ix (Map.empty :: Map String (Set Foo)),+ empty = ixSet [Ix (Map.empty :: Map String (Set Foo)), Ix (Map.empty :: Map Int (Set Foo))] calcs (Foo s _) = s ++ "bar" -t1, t2, t3 :: Foo-t1 = Foo "foo" 2-t2 = Foo "foo" 3-t3 = Foo "goo" 3+type Foos = IxSet Foo -ts :: [Foo]-ts = [t1, t2, t3] -ixset :: IxSet Foo-ixset = fromList ts -xml :: [Element]-xml = toXml ixset+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)+ ] -ixset' :: Maybe (IxSet Foo)-ixset' = fromXml Rigid xml+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 -ts' :: Maybe [Foo]-ts' = fmap toList ixset'+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 -ixSet001 :: Test-ixSet001 = "ixSet001" ~: (Just ts) @=? ts'+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))+ ]++++instance Arbitrary Foo where+ arbitrary = liftM2 Foo arbitrary arbitrary++instance (Arbitrary a,Data.Data a, Ord a, Indexable a b) => + 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)+ allTests :: Test-allTests = "happstack-ixset" ~: [ixSet001]+allTests = "happstack-ixset" ~: [ ixSetCheckMethodsOnDefault+ , ixSetCheckSetMethods+ , badIndexSafeguard+ , test (True @=? findElement 1 1)+ , 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]]++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)+-}