{- | This module implements an experimental typed query language for TCache build on pure haskell. It is minimally intrusive (no special data definitions, no special syntax, no template haskell). It uses the same register fields from the data definitions. Both for both query conditions and selections. It is executed in haskell, no external database support is needed. it includes - A method to trigger the 'index'-ation of values of the record fields that you want to query - A typed query language of these record fields, with * Relational operators: '.==.' '.>.' '.>=.' '.<=.' '.<.' '.&&.' '.||.' to compare fields with values(returning lists of DBRefs) or fields between them, returning joins (lists of pairs of lists of DBRefs that meet the condition). * a 'select' method to extract tuples of field values from the DBRefs * a 'recordsWith' clause to extract entire registers An example that register the owner and name fields fo the Car register and the name of the Person register, create the Bruce register, return the Bruce DBRef, create two Car registers with bruce as owner and query for the registers with bruce as owner and its name alpabeticaly higuer than \"Bat mobile\" @ import "Data.TCache" import "Data.TCache.IndexQuery" import "Data.TCache.FilePersistence" import "Data.Typeable" data Person= Person {pname :: String} deriving (Show, Read, Eq, Typeable) data Car= Car{owner :: DBRef Person , cname:: String} deriving (Show, Read, Eq, Typeable) instance 'Indexable' Person where key Person{pname= n} = \"Person \" ++ n instance 'Indexable' Car where key Car{cname= n} = \"Car \" ++ n main = do 'index' owner 'index' pname 'index' cname bruce <- atomically $ 'newDBRef' $ Person \"bruce\" atomically $ mapM_ 'newDBRef' [Car bruce \"Bat Mobile\", Car bruce \"Porsche\"] r \<- atomically $ 'select' (cname, owner) $ (owner '.==.' bruce) '.&&.' (cname '.>.' \"Bat Mobile\") print r @ Will produce: > [("Porsche",DBRef "Person bruce")] NOTES: * the index is instance of 'Indexable' and 'Serializable'. This can be used to persist in the user-defined storoage. If "Data.TCache.FilePersistence" is included the indexes will be written in files. * The Join feature has not been properly tested * Record fields are recognized by its type, so > data Person = Person {name , surname :: String} @name '.==.' "Bruce"@ is equual to @surname '.==.' "Bruce"@ Will return all the registers with surname "Bruce" as well. So if two or more fields in a registers are to be indexed, they must have different types. -} {-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses , FunctionalDependencies, FlexibleInstances, UndecidableInstances , TypeSynonymInstances, IncoherentInstances #-} module Data.TCache.IndexQuery(index,RelationOps(..), recordsWith, (.&&.), (.||.), Select(..)) where import Data.TCache import Data.List import Data.Typeable import Control.Concurrent.STM import Data.Maybe (catMaybes) import qualified Data.Map as M import Data.IORef import qualified Data.Map as M import System.IO.Unsafe newtype Index reg a= Index (M.Map a [DBRef reg]) deriving (Read, Show, Typeable) keyIndex treg tv= "Index " ++ show treg ++ show tv instance (Typeable reg, Typeable a) => Indexable (Index reg a) where key map= keyIndex typeofreg typeofa where [typeofreg, typeofa]= typeRepArgs $! typeOf map instance (IResource reg,Typeable reg, Ord a,Read reg, Read a, Show reg, Show a) => Serializable (Index reg a) where serialize= show deserialize= read instance (Typeable reg, Typeable a, Read reg, Show reg , Read a, Show a, Ord a, IResource reg) => IResource (Index reg a) where keyResource = key writeResource s=do mf <- readIORef persistIndex case mf of Nothing -> defaultWriteResource s ; Just (PersistIndex _ f _) -> f $ serialize s readResourceByKey s= do mf <- readIORef persistIndex case mf of Nothing -> defaultReadResourceByKey s; Just (PersistIndex f _ _) -> f s >>= return . fmap deserialize delResource s= do mf <- readIORef persistIndex case mf of Nothing -> defaultDelResource s; Just (PersistIndex _ _ f) -> f$ keyResource s data PersistIndex= PersistIndex{ readIndexByKey :: (String -> IO(Maybe String)) , writeIndex :: (String -> IO()) , deleteIndex :: (String -> IO())} setPersistIndex :: PersistIndex -> IO () setPersistIndex p = writeIORef persistIndex $ Just p persistIndex :: IORef (Maybe PersistIndex) persistIndex = unsafePerformIO $ newIORef Nothing getIndex selector val= do let [one, two]= typeRepArgs $! typeOf selector let rindex= getDBRef $! keyIndex one two getIndexr rindex val getIndexr rindex val= do mindex <- readDBRef rindex let index = case mindex of Just (Index index) -> index; _ -> M.empty let dbrefs= case M.lookup val index of Just dbrefs -> dbrefs Nothing -> [] return (rindex, Index index, dbrefs) selectorIndex :: (Typeable reg, IResource reg, Typeable a, Read reg, Show reg, Read a, Show a, Ord a, Indexable reg) => (reg -> a) -> DBRef (Index reg a) -> DBRef reg -> Maybe reg -> STM () selectorIndex selector rindex pobject mobj = do moldobj <- readDBRef pobject choice moldobj mobj where choice moldobj mobj= case (moldobj, mobj) of (Nothing, Nothing) -> return() (Just oldobj, Just obj) -> if selector oldobj==selector obj then return () else do choice moldobj Nothing choice Nothing mobj (Just oldobj, Nothing) -> do -- delete the old selector value from the index let val= selector oldobj (rindex,Index index, dbrefs) <- getIndexr rindex val let dbrefs'= Data.List.delete pobject dbrefs writeDBRef rindex $ Index (M.insert val dbrefs' index) (Nothing, Just obj) -> do -- add the new value to the index let val= selector obj (rindex,Index index, dbrefs) <- getIndexr rindex val let dbrefs'= nub $ Data.List.insert pobject dbrefs writeDBRef rindex $ Index (M.insert val dbrefs' index) {- | Register a trigger for indexing the values of the field passed as parameter. the indexed field can be used to perform relational-like searches -} index :: (Typeable reg, Typeable a, Read reg, Show reg, Read a, Show a, Ord a, IResource reg, Indexable reg) => (reg -> a) -> IO () index sel= let [one, two]= typeRepArgs $! typeOf sel rindex= getDBRef $! keyIndex one two in addTrigger $ selectorIndex sel rindex -- | implement the relational-like operators, operating on record fields class RelationOps field1 field2 res | field1 field2 -> res where (.==.) :: field1 -> field2 -> STM res (.>.) :: field1 -> field2 -> STM res (.>=.):: field1 -> field2 -> STM res (.<=.) :: field1 -> field2 -> STM res (.<.) :: field1 -> field2 -> STM res -- Instance of relations betweeen fields and values -- field .op. valued instance (Indexable reg, Typeable reg, Typeable a, Show reg, Ord a, Show a, Read a, IResource reg, Read reg) => RelationOps (reg -> a) a [DBRef reg] where (.==.) field value= do (_ ,_ ,dbrefs) <- getIndex field value return dbrefs (.>.) field value= retrieve field value (>) (.>=.) field value= retrieve field value (>=) (.<.) field value= retrieve field value (<) (.<=.) field value= retrieve field value (<=) join:: (Typeable rec,IResource rec, Typeable v, Typeable rec', IResource rec', Read v, Show v, Read rec, Show rec, Ord v, Read rec', Show rec') =>(v->v-> Bool) -> (rec -> v) -> (rec' -> v) -> STM[([DBRef rec], [DBRef rec'])] join op field1 field2 =do idxs <- retrieveIndexes field1 idxs' <- retrieveIndexes field2 return $ mix idxs idxs' where opv (v, _ )(v', _)= v `op` v' mix xs ys= let zlist= [(x,y) | x <- xs , y <- ys, x `opv` y] in map ( \(( _, xs),(_ ,ys)) ->(xs,ys)) zlist type JoinData reg reg'=[([DBRef reg],[DBRef reg'])] -- Instance of relations betweeen fields -- field1 .op. field2 instance (IResource reg, Typeable reg, IResource reg', Typeable reg', Typeable a, Ord a, Read a, Show a, Read reg, Show reg, Read reg', Show reg', Serializable a) =>RelationOps (reg -> a) (reg' -> a) (JoinData reg reg') where (.==.)= join (==) (.>.) = join (>) (.>=.)= join (>=) (.<=.)= join (<=) (.<.) = join (<) class SetOperations set set' setResult | set set' -> setResult where (.||.) :: STM set -> STM set' -> STM setResult (.&&.) :: STM set -> STM set' -> STM setResult instance SetOperations [DBRef a] [DBRef a] [DBRef a] where (.&&.) fxs fys= do xs <- fxs ys <- fys return $ intersect xs ys (.||.) fxs fys= do xs <- fxs ys <- fys return $ union xs ys instance SetOperations (JoinData a a') [DBRef a] (JoinData a a') where (.&&.) fxs fys= do xss <- fxs ys <- fys return [(intersect xs ys, zs) | (xs,zs) <- xss] (.||.) fxs fys= do xss <- fxs ys <- fys return [(union xs ys, zs) | (xs,zs) <- xss] instance SetOperations [DBRef a] (JoinData a a') (JoinData a a') where (.&&.) fxs fys= fys .&&. fxs (.||.) fxs fys= fys .||. fxs instance SetOperations (JoinData a a') [DBRef a'] (JoinData a a') where (.&&.) fxs fys= do xss <- fxs ys <- fys return [(zs,intersect xs ys) | (zs,xs) <- xss] (.||.) fxs fys= do xss <- fxs ys <- fys return [(zs, union xs ys) | (zs,xs) <- xss] retrieveIndexes :: (Typeable reg, Typeable a, Read a, Show a , Read reg, Show reg, Ord a, IResource reg) => (reg -> a) -> STM [(a,[DBRef reg])] retrieveIndexes selector= do let [one, two]= typeRepArgs $! typeOf selector let rindex= getDBRef $! keyIndex one two mindex <- readDBRef rindex case mindex of Just (Index index) -> return $ M.toList index; _ -> return [] retrieve field value op= do index <- retrieveIndexes field let higuer = map (\(v, vals) -> if op v value then vals else []) index return $ concat higuer recordsWith :: (IResource a, Typeable a) => STM [DBRef a] -> STM [ a] recordsWith dbrefs= dbrefs >>= mapM readDBRef >>= return . catMaybes class Select selector a res | selector a -> res where select :: selector -> a -> res {- instance (Select sel1 a res1, Select sel2 b res2 ) => Select (sel1, sel2) (a , b) (res1, res2) where select (sel1,sel2) (x, y) = (select sel1 x, select sel2 y) -} instance (Typeable reg, IResource reg) => Select (reg -> a) (STM [DBRef reg]) (STM [a]) where select sel xs= return . map sel =<< return . catMaybes =<< mapM readDBRef =<< xs instance (Typeable reg, IResource reg, Select (reg -> a) (STM [DBRef reg]) (STM [a]), Select (reg -> b) (STM [DBRef reg]) (STM [b]) ) => Select ((reg -> a),(reg -> b)) (STM [DBRef reg]) (STM [(a,b)]) where select (sel, sel') xs= mapM (\x -> return (sel x, sel' x)) =<< return . catMaybes =<< mapM readDBRef =<< xs instance (Typeable reg, IResource reg, Select (reg -> a) (STM [DBRef reg]) (STM [a]), Select (reg -> b) (STM [DBRef reg]) (STM [b]), Select (reg -> c) (STM [DBRef reg]) (STM [c]) ) => Select ((reg -> a),(reg -> b),(reg -> c)) (STM [DBRef reg]) (STM [(a,b,c)]) where select (sel, sel',sel'') xs= mapM (\x -> return (sel x, sel' x, sel'' x)) =<< return . catMaybes =<< mapM readDBRef =<< xs instance (Typeable reg, IResource reg, Select (reg -> a) (STM [DBRef reg]) (STM [a]), Select (reg -> b) (STM [DBRef reg]) (STM [b]), Select (reg -> c) (STM [DBRef reg]) (STM [c]), Select (reg -> d) (STM [DBRef reg]) (STM [d]) ) => Select ((reg -> a),(reg -> b),(reg -> c),(reg -> d)) (STM [DBRef reg]) (STM [(a,b,c,d)]) where select (sel, sel',sel'',sel''') xs= mapM (\x -> return (sel x, sel' x, sel'' x, sel''' x)) =<< return . catMaybes =<< mapM readDBRef =<< xs -- for join's (field1 op field2) instance (Typeable reg, IResource reg, Typeable reg', IResource reg', Select (reg -> a) (STM [DBRef reg]) (STM [a]), Select (reg' -> b) (STM [DBRef reg']) (STM [b]) ) => Select ((reg -> a),(reg' -> b)) (STM (JoinData reg reg')) (STM [([a],[b])]) where select (sel, sel') xss = xss >>= mapM select1 where select1 (xs, ys) = do rxs <- return . map sel =<< return . catMaybes =<< mapM readDBRef xs rys <- return . map sel' =<< return . catMaybes =<< mapM readDBRef ys return (rxs,rys)