HAppS-IxSet (empty) → 0.9.2
raw patch · 5 files changed
+587/−0 lines, 5 filesdep +HAppS-Datadep +HAppS-Statedep +HAppS-Utilsetup-changed
Dependencies added: HAppS-Data, HAppS-State, HAppS-Util, base, containers, hslogger, mtl, syb-with-class, template-haskell
Files
- HAppS-IxSet.cabal +26/−0
- Setup.hs +2/−0
- src/HAppS/Data/IxSet.hs +445/−0
- src/HAppS/Data/IxSet/Ix.hs +63/−0
- src/HAppS/Data/IxSet/Usage.hs +51/−0
+ HAppS-IxSet.cabal view
@@ -0,0 +1,26 @@+Name: HAppS-IxSet+Version: 0.9.2+Description: Web framework+License: BSD3+Copyright: 2007 HAppS LLC+Author: Alex Jacobson, Einar Karttunen+Maintainer: AlexJacobson@HAppS.org+Category: Web, Distributed Computing+Build-Depends: base, mtl, hslogger >= 1.0.2, HAppS-Util >=0.9.2,+ HAppS-State >=0.9.2, HAppS-Data >=0.9.2, template-haskell,+ syb-with-class, containers+Build-Type: Simple+hs-source-dirs: src+Exposed-modules: + HAppS.Data.IxSet+ HAppS.Data.IxSet.Ix+ HAppS.Data.IxSet.Usage+extensions: CPP, ForeignFunctionInterface,+ OverlappingInstances, UndecidableInstances,+ RecursiveDo,+ RankNTypes, FlexibleInstances,+ TypeSynonymInstances+-- Should have ", DeriveDataTypeable", but Cabal complains+cpp-options: -DUNIX+ghc-options: -Wall -fno-warn-incomplete-patterns+GHC-Prof-Options: -auto-all
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMainWithHooks defaultUserHooks
+ src/HAppS/Data/IxSet.hs view
@@ -0,0 +1,445 @@+{-# LANGUAGE UndecidableInstances, OverlappingInstances, FlexibleInstances,+ MultiParamTypeClasses, TemplateHaskell, RankNTypes,+ FunctionalDependencies, DeriveDataTypeable,+ GADTs #-}+++{--+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++ 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++3. Use insert/delete/replace and empty to build up an IxSet collection++ entries = foldr insert empty [e1,e2,e3,e4]+ entries' = foldr delete entries [e1,e3]+ entries'' = update e4 e5 entries++4. Use the query functions below to grab data from it. e.g.++ entries @< (Updated t1) @= (Author "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+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++ instance Indexable Entry [Word] where+ ....+ calcs entry = getWords entry++Now you can do this query to find entries with any of the words++ entries @+ [Word "word1",Word "word2"]++And if you want all entries with both:++ entries @* [Word "word1",Word "word2"]++6. Find the only the first author++If an Entry has multiple authors and you want to be able to query+on the first author, define a FirstAuthor datatype and add it to the+result of calc. calc e=(toWords e,getFirstAuthor e) and now you can+do++ newtype FirstAuthor = FirstAuthor Email+ getFirstAuthor = let Just (Author a)=gGet Entry in FirstAuthor a++ instance Indexable Entry ([Word],FirstAuthor)+ ...+ empty = ....+ Ix (Map.empty::Map FirstAuthor (Set Entry))]+ calcs entry = (getWords Entry,getFirstAuthor entry)++ entries @= (FirstAuthor "john@doe.com") -- guess what this does++--}++module HAppS.Data.IxSet (module HAppS.Data.IxSet,+ module Ix)+ where++import qualified HAppS.Data.IxSet.Ix as Ix+import HAppS.Data.IxSet.Ix (Ix(Ix))+import Data.Generics hiding (GT)+import Data.Dynamic+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+import Data.Set (Set)+import qualified Data.Set as Set+import HAppS.Util.Common+import Control.Monad.Reader+import Language.Haskell.TH as TH++import HAppS.Util.TH+import HAppS.State+import HAppS.Data+import qualified Data.Generics.SYB.WithClass.Basics as SYBWC++{--+-- experimental code for using hlist for the indices rather than existetials+type Ix2 rec val = Map val (Set rec)+++ixType= (ix::Ix2 Entry Author) .&.+ (ix::Ix2 Entry Updated) .&.+ (ix::Ix2 Entry Word) .&.+ Nil++data IxSet2 entry calcs ixs = IxSet2 (entry->calcs) ixs+insIndex2 k v ixs = trans (insertIndex k v) ixs+delIndex2 k v ixs = trans (deleteIndex k v) ixs++change2 op val (IxSet2 calc ixs) = IxSet2 calc ixs+ where+ keys = flatten (val,calc val)+--}++++-- the core datatypes++data IxSet a = ISet [a] | IxSet [Ix a]+ deriving (Data, Typeable)++instance Version (IxSet a)+instance (Serialize a, Ord a, Data a, Indexable a b) => Serialize (IxSet a) where+ putCopy ixset = contain $ safePut (toList ixset)+ 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)+ => 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)+ 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]++++instance (Indexable a b, Data a, Ord a, Default a) => Default (IxSet a) where+ defaultValue = ISet []++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+++class (Data b) => Indexable a b | a->b where+ empty :: IxSet a -- defines what types are indexed and queryable+ calcs :: a->b -- adds indexable values not found in the type+ -- if you don't want calculated values use DB a ()+ --should this be a fromDyn so we can provide a default impl?++noCalcs x = ()++{--+inferIndexable :: TH.Name -> TH.Name -> [TH.Name] -> Q [Dec]+inferIndexable aType calName entryPoints+ = do calInfo <- reify calName+ case calInfo of+ VarI _ t _ _ ->+ let calType = getCalType t+ getCalType (AppT (AppT ArrowT _) t) = t+ getCalType (ForallT _ _ t) = getCalType t+ getCalType t = error ("Unexpected type: " ++ pprint t)+ mkEntryPoint n = appE (conE 'Ix) (sigE (varE 'Map.empty) (appT (appT (conT ''Map) (conT n)) (appT (conT ''Set) (conT aType))))+ in do i <- instanceD (cxt []) (appT (appT (conT ''Indexable) (conT aType)) (return calType))+ [ liftM head [d| empty = IxSet $(listE (map mkEntryPoint entryPoints)) |]+ , liftM head [d| calcs = $(varE calName) |]+ ]+-- runIO (putStrLn (pprint i))+ return [i]+--}+++inferIxSet :: String -> TH.Name -> TH.Name -> [TH.Name] -> Q [Dec]+inferIxSet ixset typeName calName entryPoints+ = do calInfo <- reify calName+ typeInfo <- reify typeName+ let (context,names) = case typeInfo of+ TyConI (DataD context _ names _ _) -> (context,names)+ TyConI (NewtypeD context _ names _ _) -> (context,names)+ TyConI (TySynD _ names _) -> ([],names)+ typeCon = foldl appT (conT typeName) (map varT names)+ 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))+ [d| empty :: IxSet a+ empty = IxSet $(listE (map mkEntryPoint entryPoints))+ calcs :: a -> b+ calcs = $(varE calName) |]+-- runIO (putStrLn (pprint i))+ let ixType = appT (conT ''IxSet) typeCon+ ixType' <- tySynD (mkName ixset) names ixType+ -- runIO (putStrLn (pprint t))+ --d <- return $ deriveDefault' True [aType] ''IxSet+ --runIO (putStrLn (pprint d))+ return $ [i, ixType'] -- ++ d+++++++-- modification operations++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)++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)+ where+ update [] _ = []+ update _ [] = []+ update (Ix index:is) dyns = Ix index':update is dyns'+ 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++insert :: (Data a, Ord a,Data b,Indexable a b) => a -> IxSet a -> IxSet a+insert = change Ix.insert++delete :: (Data a, Ord a,Data b,Indexable a b) => a -> IxSet a -> IxSet a+delete = change Ix.delete++--update old new = insert new . delete old++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++-- conversion operations++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' :: Ord a => [Ix a] -> Set a+toSet' (Ix ix:_) = Map.fold Set.union Set.empty ix+toSet' [] = Set.empty++fromSet :: (Indexable a b, Ord a, Data a) => Set a -> IxSet a+fromSet set = Set.fold insert empty set++fromSet' :: (Indexable a b, Ord a, Data a) => Set a -> IxSet a+fromSet' set = Set.fold insert empty set++fromList :: (Indexable a b, Ord a, Data a) => [a] -> IxSet a+fromList list = fromSet $ Set.fromList list++size :: Ord a => IxSet a -> Int+size x = Set.size $ toSet x++toList :: Ord a => IxSet a -> [a]+toList x = Set.toList $ toSet x++toList' :: Ord a => [Ix a] -> [a]+toList' x = Set.toList $ toSet' x++getOne :: Ord a => IxSet a -> Maybe a+getOne ixset = case toList ixset of+ [x] -> Just x+ _ -> Nothing++getOneOr :: Ord a => a -> IxSet a -> a+getOneOr def = fromMaybe def . getOne++{--+split es = (e1',e2')+ where+ set = toSet es+ num = Set.size set+ (e1,e2) = splitAt (num `div` 2) $ Set.toList set+ (e1',e2') = (fromSet $ Set.fromList e1,fromSet $ Set.fromList e2)+merge (e1,e2) = fromList $ (e1' ++ e2')+ where+ (e1',e2') = (toList e1,toList e2)+--}++-- set operations+(&&&) :: (Ord a, Data a, Indexable a b) => IxSet a -> IxSet a -> IxSet a+x1 &&& x2 = intersection x1 x2++(|||) :: (Ord a, Data a, Indexable a b) => IxSet a -> IxSet a -> IxSet a+x1 ||| x2 = union x1 x2++infixr 5 &&&+infixr 5 |||++union :: (Ord a, Data a, Indexable a b) => IxSet a -> IxSet a -> IxSet a+union x1 x2 = fromSet $ Set.union (toSet x1) (toSet x2)++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+(@=), (@<), (@>), (@<=), (@>=)+ :: (Indexable a b, Data a, Ord a, Typeable k)+ => IxSet a -> k -> IxSet a+ix @= v = getEQ v ix+ix @< v = getLT v ix+ix @> v = getGT v ix+ix @<= v = getLTE v ix+ix @>= v = getGTE v ix++(@><), (@>=<), (@><=), (@>=<=)+ :: (Indexable a b, Data a, Ord a, Typeable k)+ => IxSet a -> (k, k) -> IxSet a+ix @>< (v1,v2) = getLT v2 $ getGT v1 ix+ix @>=< (v1,v2) = getLT v2 $ getGTE v1 ix+ix @><= (v1,v2) = getLTE v2 $ getGT v1 ix+ix @>=<= (v1,v2) = getLTE v2 $ getGTE v1 ix++(@+), (@*)+ :: (Indexable a b, Data a, Ord a, Typeable k)+ => IxSet a -> [k] -> IxSet a+ix @+ list = foldr union empty $ map (ix @=) list+ix @* list = foldr intersection empty $ map (ix @=) list++getEQ :: (Indexable a b, Data a, Ord a, Typeable k)+ => k -> IxSet a -> IxSet a+getEQ v ix = getOrd EQ v ix++getLT :: (Indexable a b, Data a, Ord a, Typeable k)+ => k -> IxSet a -> IxSet a+getLT v ix = getOrd LT v ix++getGT :: (Indexable a b, Data a, Ord a, Typeable k)+ => k -> IxSet a -> IxSet a+getGT v ix = getOrd GT v ix++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++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+++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)++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)+ f = mapSnd Set.toList . Map.toList++rGroupBy x = reverse $ groupBy x+--rOrderBy x = reverse $ orderBy x++ +--query impl function+getOrd :: (Indexable a b, Ord a, Data a, Typeable k)+ => Ordering -> k -> IxSet a -> IxSet a+getOrd ord v (IxSet indices) = collect indices+ where+ v' = toDyn v+ collect [] = empty+ collect (Ix index:is) = maybe (collect is) f $ fromDynamic v'+ where+ f v'' = foldr insert empty $+ case ord of+ LT -> lt+ GT -> gt+ EQ -> eq+ where+ (lt',eq',gt')=Map.splitLookup v'' index+ lt = concat $ map (Set.toList . snd) $ Map.toList lt'+ gt = concat $ map (Set.toList . snd) $ Map.toList gt'+ eq = maybe [] Set.toList eq'++--we want a gGets that returns a list of all matches++{--+Optimization todo:++* can we avoid rebuilding the collection every time we query?+ does laziness take care of everything?++* 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+ mappend = union+
+ src/HAppS/Data/IxSet/Ix.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE UndecidableInstances, OverlappingInstances, FlexibleInstances,+ MultiParamTypeClasses, TemplateHaskell, PolymorphicComponents,+ DeriveDataTypeable,ExistentialQuantification #-}++module HAppS.Data.IxSet.Ix 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 HAppS.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))+ deriving Typeable++ -- minimal hacky instance+instance Data a => Data (Ix a) where+ toConstr (Ix _) = con_Ix_Data+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = ixType_Data++con_Ix_Data :: Constr+con_Ix_Data = mkConstr ixType_Data "Ix" [] Prefix+ixType_Data :: DataType+ixType_Data = mkDataType "HAppS.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]++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++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++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'+
+ src/HAppS/Data/IxSet/Usage.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE UndecidableInstances, OverlappingInstances, FlexibleInstances+ ,MultiParamTypeClasses, TemplateHaskell, DeriveDataTypeable #-}++-- XXX This modules should be turned into documentation and/or test cases++module HAppS.Data.IxSet.Usage where++import HAppS.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+